Menu
▾
▴
hoc-cvs — CVS commit log messages
You can subscribe to this list here.
| 2004 |
Jan
|
Feb
|
Mar
|
Apr
|
May
(127) |
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
(6) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2005 |
Jan
|
Feb
|
Mar
(35) |
Apr
(23) |
May
|
Jun
(1) |
Jul
(48) |
Aug
(23) |
Sep
(10) |
Oct
(4) |
Nov
|
Dec
|
| 2006 |
Jan
|
Feb
|
Mar
(27) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(7) |
Dec
|
| 2007 |
Jan
|
Feb
(16) |
Mar
(2) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2008 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
(19) |
Oct
(25) |
Nov
(8) |
Dec
(25) |
| 2009 |
Jan
(6) |
Feb
(1) |
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(25) |
Sep
(2) |
Oct
|
Nov
|
Dec
|
| 2010 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
(3) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: <cod...@go...> - 2008-10-23 22:18:04
|
Author: wol...@gm...
Date: Thu Oct 23 15:16:51 2008
New Revision: 341
Modified:
trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs
Log:
Apply duplicate entity removal to all non-anonymous entities.
This way, we don't get into trouble when someone dares to define
the same thing twice.
Modified: trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs Thu Oct 23 15:16:51
2008
@@ -26,11 +26,9 @@
[ ((eHaskellName e, eName e, eInfo e), Set.singleton ei)
| (ei, e) <- Map.toList $ frameworkEntities entityPile,
interesting e ]
-
- interesting (Entity { eInfo = SelectorEntity _}) = True
- interesting (Entity { eInfo = MethodEntity }) = True
- interesting (Entity { eInfo = ProtocolAdoptionEntity }) = True
- interesting _ = False
+
+ interesting (Entity { eName = Anonymous }) = False
+ interesting _ = True
pickMasterEntity :: Map.Map Module Int -> EntityPile -> [EntityID] ->
(EntityID, [EntityID])
|
|
From: <cod...@go...> - 2008-10-19 20:58:35
|
Author: wol...@gm...
Date: Sun Oct 19 13:57:37 2008
New Revision: 340
Modified:
trunk/hoc/HOC/HOC/FFICallInterface.hs
trunk/hoc/HOC/HOC/Invocation.hs
Log:
libffi returns small integral return values promoted to long.
Deal with it.
Modified: trunk/hoc/HOC/HOC/FFICallInterface.hs
==============================================================================
--- trunk/hoc/HOC/HOC/FFICallInterface.hs (original)
+++ trunk/hoc/HOC/HOC/FFICallInterface.hs Sun Oct 19 13:57:37 2008
@@ -1,4 +1,11 @@
-module HOC.FFICallInterface where
+module HOC.FFICallInterface(
+ FFICif,
+ FFIType,
+ FFITypeable(..),
+ ffiPrepCif,
+ makeStructType,
+ cifIsStret
+ ) where
import Foreign.C.Types
import Foreign
@@ -15,6 +22,17 @@
isStructType :: a -> Bool
isStructType _ = False
+
+ -- Integral return values of size < sizeof(long) require special
treatment
+ -- in libffi; they are returned as long. For these types, the following
+ -- gives us a chance to replace alloca & peek with a version that
undoes
+ -- the promotion.
+
+ peekRetval :: Storable a => Ptr a -> IO a
+ allocaRetval :: Storable a => (Ptr a -> IO b) -> IO b
+
+ peekRetval = peek
+ allocaRetval = alloca
foreign import ccall "ffi.h &ffi_type_void" ffi_type_void :: FFIType
foreign import ccall "ffi.h &ffi_type_uint8" ffi_type_uint8:: FFIType
@@ -54,6 +72,15 @@
foreign import ccall unsafe cifIsStret :: FFICif -> IO CInt
+promotedPeek p
+ = peek (castPtr p :: Ptr CLong) >>= return . fromIntegral
+ where
+ size = sizeOf (pointee p)
+ pointee :: Ptr p -> p
+ pointee = undefined
+
+promotedAlloca f = alloca (\intPtr -> f $ castPtr (intPtr :: Ptr CLong))
+
-- typeable instances
instance FFITypeable () where
@@ -64,19 +91,43 @@
instance FFITypeable Int8 where
makeFFIType _ = return ffi_type_sint8
+
+ peekRetval = promotedPeek
+ allocaRetval = promotedAlloca
+
instance FFITypeable Int16 where
makeFFIType _ = return ffi_type_sint16
+
+ peekRetval = promotedPeek
+ allocaRetval = promotedAlloca
+
instance FFITypeable Int32 where
makeFFIType _ = return ffi_type_sint32
+
+ peekRetval = promotedPeek -- only takes effect on 64-bit
+ allocaRetval = promotedAlloca
+
instance FFITypeable Int64 where
makeFFIType _ = return ffi_type_sint64
instance FFITypeable Word8 where
makeFFIType _ = return ffi_type_uint8
+
+ peekRetval = promotedPeek
+ allocaRetval = promotedAlloca
+
instance FFITypeable Word16 where
makeFFIType _ = return ffi_type_uint16
+
+ peekRetval = promotedPeek
+ allocaRetval = promotedAlloca
+
instance FFITypeable Word32 where
makeFFIType _ = return ffi_type_uint32
+
+ peekRetval = promotedPeek -- only takes effect on 64-bit
+ allocaRetval = promotedAlloca
+
instance FFITypeable Word64 where
makeFFIType _ = return ffi_type_uint64
@@ -101,20 +152,34 @@
instance FFITypeable CChar where
makeFFIType _ = return ffi_type_sint8
+ peekRetval = promotedPeek
+ allocaRetval = promotedAlloca
instance FFITypeable CUChar where
makeFFIType _ = return ffi_type_uint8
+ peekRetval = promotedPeek
+ allocaRetval = promotedAlloca
instance FFITypeable CSChar where
makeFFIType _ = return ffi_type_sint8
+ peekRetval = promotedPeek
+ allocaRetval = promotedAlloca
instance FFITypeable CShort where
makeFFIType _ = return ffi_type_sint16
+ peekRetval = promotedPeek
+ allocaRetval = promotedAlloca
instance FFITypeable CUShort where
makeFFIType _ = return ffi_type_uint16
+ peekRetval = promotedPeek
+ allocaRetval = promotedAlloca
instance FFITypeable CInt where
makeFFIType _ = return ffi_type_sint32
+ peekRetval = promotedPeek
+ allocaRetval = promotedAlloca
instance FFITypeable CUInt where
makeFFIType _ = return ffi_type_uint32
+ peekRetval = promotedPeek
+ allocaRetval = promotedAlloca
instance FFITypeable CLong where
makeFFIType _ = return ffi_type_sint32
Modified: trunk/hoc/HOC/HOC/Invocation.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Invocation.hs (original)
+++ trunk/hoc/HOC/HOC/Invocation.hs Sun Oct 19 13:57:37 2008
@@ -38,9 +38,9 @@
-> IO b
callWithRetval cif fun args = do
- alloca $ \retptr ->
+ allocaRetval $ \retptr ->
callWithException cif fun retptr args
- >> peek retptr >>= importArgument
+ >> peekRetval retptr >>= importArgument
setMarshalledRetval :: ObjCArgument a b => Bool -> Ptr () -> a -> IO ()
|
|
From: <cod...@go...> - 2008-10-19 20:36:33
|
Author: wol...@gm...
Date: Sun Oct 19 13:32:25 2008
New Revision: 339
Modified:
trunk/hoc/Bindings/make-bindings-macos.sh
Log:
change to correct directory
Modified: trunk/hoc/Bindings/make-bindings-macos.sh
==============================================================================
--- trunk/hoc/Bindings/make-bindings-macos.sh (original)
+++ trunk/hoc/Bindings/make-bindings-macos.sh Sun Oct 19 13:32:25 2008
@@ -1,6 +1,6 @@
function build()
{
- pushd $1
+ pushd HOC-$1
runhaskell Setup.hs configure $ARGUMENTS
runhaskell Setup.hs build
runhaskell Setup.hs install
|
|
From: <cod...@go...> - 2008-10-19 20:32:21
|
Author: wol...@gm...
Date: Sun Oct 19 13:31:18 2008
New Revision: 338
Modified:
trunk/hoc/HOC/HOC/DeclareSelector.hs
Log:
"kill" some dead code
Modified: trunk/hoc/HOC/HOC/DeclareSelector.hs
==============================================================================
--- trunk/hoc/HOC/HOC/DeclareSelector.hs (original)
+++ trunk/hoc/HOC/HOC/DeclareSelector.hs Sun Oct 19 13:31:18 2008
@@ -246,8 +246,7 @@
sigD (mkName infoName) [t| SelectorInfo |],
-- $(infoName) = ...
- let e = [| undefined |] `sigE` (return $ simplifyType
doctoredTypeSig)
- in valD (varP $ mkName $ infoName) (normalB
+ valD (varP $ mkName $ infoName) (normalB
[|
let n = $(stringE name)
in $(selInfoMaker) n
|
|
From: <cod...@go...> - 2008-10-15 23:25:19
|
Author: wol...@gm...
Date: Wed Oct 15 16:24:36 2008
New Revision: 337
Modified:
trunk/hoc/Bindings/AdditionalCode/Foundation/NSGeometry.hs
trunk/hoc/Bindings/AdditionalCode/Foundation/NSRange.hs
trunk/hoc/Bindings/binding-script.txt
Log:
we now have auto-generated structs!
Modified: trunk/hoc/Bindings/AdditionalCode/Foundation/NSGeometry.hs
==============================================================================
--- trunk/hoc/Bindings/AdditionalCode/Foundation/NSGeometry.hs (original)
+++ trunk/hoc/Bindings/AdditionalCode/Foundation/NSGeometry.hs Wed Oct 15
16:24:36 2008
@@ -1,11 +1,6 @@
--- above NSGeometry
--- CUT HERE
--- below NSGeometry
+import Prelude
-- CUT HERE
--- above NSGeometry.Forward
---X NSPoint(..)
---X NSSize(..)
---X NSRect(..)
+
--X nsMaxX
--X nsMaxY
--X nsMidX
@@ -15,23 +10,6 @@
--X nsWidth
--X nsHeight
-
-import Foreign
-import Prelude
--- CUT HERE
--- below NSGeometry.Forward
-
-data NSPoint = NSPoint Float Float deriving(Read, Show, Eq)
-data NSSize = NSSize Float Float deriving(Read, Show, Eq)
-data NSRect = NSRect NSPoint NSSize deriving(Read, Show, Eq)
-
-{-
--- They're imported automatically now.
-nsZeroPoint = NSPoint 0 0
-nsZeroSize = NSSize 0 0
-nsZeroRect = NSRect nsZeroPoint nsZeroSize
--}
-
nsMaxX (NSRect (NSPoint x y) (NSSize w h)) = x + w
nsMaxY (NSRect (NSPoint x y) (NSSize w h)) = y + h
nsMidX (NSRect (NSPoint x y) (NSSize w h)) = x + w / 2.0
@@ -40,53 +18,3 @@
nsMinY (NSRect (NSPoint x y) (NSSize w h)) = y
nsWidth (NSRect (NSPoint x y) (NSSize w h)) = w
nsHeight (NSRect (NSPoint x y) (NSSize w h)) = h
-
-instance Storable NSPoint where
- alignment _ = alignment (undefined :: Float)
- sizeOf _ = 2 * sizeOf (undefined :: Float)
- peek p = do x <- peekElemOff (castPtr p) 0
- y <- peekElemOff (castPtr p) 1
- return (NSPoint x y)
- poke p (NSPoint x y) = do pokeElemOff (castPtr p) 0 x
- pokeElemOff (castPtr p) 1 y
-
-
-
-instance Storable NSSize where
- alignment _ = alignment (undefined :: Float)
- sizeOf _ = 2 * sizeOf (undefined :: Float)
- peek p = do w <- peekElemOff (castPtr p) 0
- h <- peekElemOff (castPtr p) 1
- return (NSSize w h)
- poke p (NSSize w h) = do pokeElemOff (castPtr p) 0 w
- pokeElemOff (castPtr p) 1 h
-
-instance Storable NSRect where
- alignment _ = alignment (undefined :: NSPoint)
- sizeOf _ = 2 * sizeOf (undefined :: NSPoint)
- peek p = do o <- peekElemOff (castPtr p) 0
- s <- peekElemOff (castPtr p) 1
- return (NSRect o s)
- poke p (NSRect o s) = do pokeElemOff (castPtr p) 0 o
- pokeElemOff (castPtr p) 1 s
-
-instance FFITypeable NSPoint where
- makeFFIType _ = do float <- makeFFIType (undefined :: Float)
- makeStructType [float, float]
- isStructType _ = True
-
-instance FFITypeable NSSize where
- makeFFIType _ = do float <- makeFFIType (undefined :: Float)
- makeStructType [float, float]
- isStructType _ = True
-
-instance FFITypeable NSRect where
- makeFFIType _ = do point <- makeFFIType (undefined :: NSPoint)
- size <- makeFFIType (undefined :: NSSize)
- makeStructType [point, size]
- isStructType _ = True
-
-
-$(declareStorableObjCArgument [t| NSPoint |] "{_NSPoint=ff}")
-$(declareStorableObjCArgument [t| NSSize |] "{_NSSize=ff}")
-$(declareStorableObjCArgument [t| NSRect |
] "{_NSRect={_NSPoint=ff}{_NSSize=ff}}")
Modified: trunk/hoc/Bindings/AdditionalCode/Foundation/NSRange.hs
==============================================================================
--- trunk/hoc/Bindings/AdditionalCode/Foundation/NSRange.hs (original)
+++ trunk/hoc/Bindings/AdditionalCode/Foundation/NSRange.hs Wed Oct 15
16:24:36 2008
@@ -1,23 +1,18 @@
--- above NSRange
--- CUT HERE
--- below NSRange
--- CUT HERE
--- above NSRange.Forward
---X NSRange(..)
--X nsMaxRange
--X nsLocationInRange
-import Foreign
-import Foreign.C.Types
+{-import Foreign
+import Foreign.C.Types-}
import Prelude
-- CUT HERE
-- below NSRange.Forward
-data NSRange = NSRange CUInt CUInt deriving(Read, Show, Eq)
+-- data NSRange = NSRange CUInt CUInt deriving(Read, Show, Eq)
nsMaxRange (NSRange loc len) = loc + len
nsLocationInRange x (NSRange loc len) = x >= loc && x < loc+len
+{-
instance Storable NSRange where
alignment _ = alignment (undefined :: CUInt)
sizeOf _ = 2 * sizeOf (undefined :: CUInt)
@@ -34,3 +29,4 @@
isStructType _ = True
$(declareStorableObjCArgument [t| NSRange |] "{_NSRange=II}")
+-}
\ No newline at end of file
Modified: trunk/hoc/Bindings/binding-script.txt
==============================================================================
--- trunk/hoc/Bindings/binding-script.txt (original)
+++ trunk/hoc/Bindings/binding-script.txt Wed Oct 15 16:24:36 2008
@@ -62,10 +62,10 @@
- (void) setContentView: (NSView*) view;
}
-type NSPoint Foundation.NSGeometry;
-type NSSize Foundation.NSGeometry;
-type NSRect Foundation.NSGeometry;
-type NSRange Foundation.NSRange;
+-- type NSPoint Foundation.NSGeometry;
+-- type NSSize Foundation.NSGeometry;
+-- type NSRect Foundation.NSGeometry;
+-- type NSRange Foundation.NSRange;
-- GNUstep specifics:
{-
|
|
From: Wolfgang T. <wth...@us...> - 2008-10-13 20:36:02
|
Update of /cvsroot/hoc/www In directory 23jxhf1.ch3.sourceforge.com:/tmp/cvs-serv23924 Modified Files: index.html Log Message: fix URL Index: index.html =================================================================== RCS file: /cvsroot/hoc/www/index.html,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- index.html 12 Oct 2008 12:00:55 -0000 1.13 +++ index.html 13 Oct 2008 20:35:54 -0000 1.14 @@ -5,7 +5,7 @@ <!--#include virtual="/templates.hoc/header.shtml" --> <h1>HOC Has Moved</h1> -<p><strong><a href="code.google.com/p/hoc">HOC has moved to Google Code.</a></strong> +<p><strong><a href="http://code.google.com/p/hoc">HOC has moved to Google Code.</a></strong> The pages at sourceforge are outdated, and so is the source code available from here.</p> <h1>About</h1> |
|
From: Wolfgang T. <wth...@us...> - 2008-10-12 12:01:05
|
Update of /cvsroot/hoc/www In directory 23jxhf1.ch3.sourceforge.com:/tmp/cvs-serv28402 Modified Files: index.html Log Message: Tell everyone we've moved Index: index.html =================================================================== RCS file: /cvsroot/hoc/www/index.html,v retrieving revision 1.12 retrieving revision 1.13 diff -u -d -r1.12 -r1.13 --- index.html 23 May 2004 16:05:53 -0000 1.12 +++ index.html 12 Oct 2008 12:00:55 -0000 1.13 @@ -4,6 +4,10 @@ <!--#include virtual="/templates.hoc/header.shtml" --> +<h1>HOC Has Moved</h1> +<p><strong><a href="code.google.com/p/hoc">HOC has moved to Google Code.</a></strong> +The pages at sourceforge are outdated, and so is the source code available from here.</p> + <h1>About</h1> <p>HOC is a <strong>H</strong>askell to |
|
From: <cod...@go...> - 2008-10-08 00:04:28
|
Author: wol...@gm...
Date: Tue Oct 7 17:01:15 2008
New Revision: 336
Modified:
trunk/hoc/InterfaceGenerator2/Parser.hs
Log:
Multiple improvements to the parser, mostly for parsing
ApplicationServices.framework
* when skipping things, take comments into account
* ignore all .*EXTERN_C_BEGIN and .*EXTERN_C_END macros at the top level
* more operators for constant int expressions (*,/,+,-,>>,|)
* accept all .*EXTERN and .*EXPORT macros in place of extern
* accept all .*INLINE macros in place of inline
* accept "static" in function prototypes
* accept prototypes for inline functions
* accept EXTERN_API[_C] and CALLBACK_API[_C] macros (for parsing Carbon
headers)
Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs Tue Oct 7 17:01:15 2008
@@ -3,8 +3,9 @@
import Data.Maybe ( isJust, fromJust )
import Data.Char ( ord, isUpper, isDigit )
-import Data.Bits ( shiftL, (.|.) )
-import Control.Monad ( guard )
+import Data.Bits ( shiftL, shiftR, (.|.) )
+import Data.List ( isSuffixOf )
+import Control.Monad ( guard, unless )
import Text.Parsec
import Text.Parsec.Token
@@ -52,7 +53,7 @@
return things
uninterestingThing :: Parser (Maybe Declaration)
-uninterestingThing = skipMany1 (satisfy (\x -> x /= '@' && x /= ';')) >>
return Nothing
+uninterestingThing = skip1 (satisfy (\x -> x /= '@' && x /= ';')) >>
return Nothing
interestingThing =
ignoredToplevelThing
@@ -61,29 +62,37 @@
<|> interface_decl
<|> empty_decl
<|> type_declaration
- <|> inline_function
<|> extern_decl
<|> (semi objc >> return [])
+definedKeyword f = try (do x <- identifier objc
+ unless (all (\c -> c == '_' || isUpper c) x &&
f x) $
+ fail "")
+
ignoredToplevelThing
- = (foldl1 (<|>) . map (reserved objc))
- ["CA_EXTERN_C_BEGIN", "CA_EXTERN_C_END",
- "CF_EXTERN_C_BEGIN", "CF_EXTERN_C_END"]
- >> return []
+ = definedKeyword (\x -> "EXTERN_C_BEGIN" `isSuffixOf` x
+ || "EXTERN_C_END" `isSuffixOf` x)
+ >> return []
--
-skipParens = parens objc (skipMany (
+skip p = do
+ whiteSpace objc
+ (p >> skip p) <|> return ()
+
+skip1 p = p >> skip p
+
+skipParens = parens objc (skip (
(satisfy (\x -> x /= '(' && x /= ')') >> return ())
<|> skipParens
))
-skipBlockContents = (skipMany (
+skipBlockContents = (skip (
(satisfy (\x -> x /= '{' && x /= '}') >> return ())
<|> skipBlock
))
skipBlock = braces objc skipBlockContents
-skipEnumValue = skipMany1 (satisfy (\x -> x /= '}' && x /= ','))
+skipEnumValue = skip (satisfy (\x -> x /= '}' && x /= ','))
-- Plain C
@@ -101,7 +110,12 @@
<|> definedConstant
<|> parens objc expr
- optable = [ [Infix (op "<<" (cast2nd shiftL)) AssocLeft],
+ optable = [ [Infix (op "*" (*)) AssocLeft,
+ Infix (op "/" div) AssocLeft],
+ [Infix (op "+" (+)) AssocLeft,
+ Infix (op "-" (-)) AssocLeft],
+ [Infix (op "<<" (cast2nd shiftL)) AssocLeft,
+ Infix (op ">>" (cast2nd shiftR)) AssocLeft],
[Infix (op "|" (.|.)) AssocLeft] ]
where
op str f = reservedOp objc str >> return f
@@ -147,6 +161,7 @@
t <- id_type
<|> enum_type
<|> struct_type
+ <|> (reserved objc "STACK_UPP_TYPE" >> parens objc simple_type)
<|> try builtin_type
<|> do n <- identifier objc
protos <- protocol_spec -- TOOD: use these protocols
@@ -197,10 +212,14 @@
postfix_operator =
brackets objc (optional (integer objc) >> return CTPointer)
- <|> do
- (args, vararg) <- parens objc arguments
- return (\retval -> CTFunction retval args vararg)
-
+ <|> function_call_declarator
+
+
+function_call_declarator
+ = do
+ (args, vararg) <- parens objc arguments
+ return (\retval -> CTFunction retval args vararg)
+ where
arguments =
do
args <- commaSep objc argument
@@ -294,16 +313,27 @@
semi objc
return [ (modifier typ, name) | (name, modifier) <- things ]
+typedef = reserved objc "typedef" >> (carbon_callback <|> real_typedef)
+ where
+ carbon_callback = do
+ reserved objc "CALLBACK_API" <|> reserved objc "CALLBACK_API_C"
+ (t,i) <- parens objc ( do t <- simple_type
+ comma objc
+ i <- identifier objc
+ return (t,i) )
+ f <- function_call_declarator
+ availability
+ semi objc
+ return $ [ Typedef (f t) i ]
-typedef = do
- reserved objc "typedef"
- baseType <- simple_type
-
- newTypes <- commaSep objc id_declarator
- availability
- semi objc
- return $ [Typedef (typeFun baseType) name
- | (name, typeFun) <- newTypes ]
+ real_typedef = do
+ baseType <- simple_type
+
+ newTypes <- commaSep objc id_declarator
+ availability
+ semi objc
+ return $ [Typedef (typeFun baseType) name
+ | (name, typeFun) <- newTypes ]
ctypeDecl = do
typ <- enum_type <|> struct_type
@@ -315,12 +345,26 @@
extern_decl =
do
- optional extern_keyword
- t <- simple_type
- vars <- commaSep objc (one_var t)
- availability
- semi objc
- return vars
+ t <- carbon_extern_api <|>
+ (many storage_class >> simple_type)
+ firstVar <- one_var t
+
+ let single_declaration_end = do
+ availability
+ semi objc
+ return [firstVar]
+ multiple_declaration_end = do
+ comma objc
+ moreVars <- commaSep objc (one_var t)
+ availability
+ semi objc
+ return $ firstVar : moreVars
+ function_definition = do
+ availability
+ skipBlock
+ return []
+
+ single_declaration_end <|> multiple_declaration_end <|>
function_definition
where
one_var t = do
(n, typeOperators) <- id_declarator
@@ -330,24 +374,17 @@
otherType
-> ExternVar otherType n
+ carbon_extern_api = (reserved objc "EXTERN_API" <|> reserved
objc "EXTERN_API_C")
+ >> parens objc simple_type
+
extern_keyword =
reserved objc "extern"
- <|> 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"
- <|> reserved objc "COREDATA_EXTERN"
-
-inline_function =
- do
- reserved objc "inline" <|> reserved objc "NS_INLINE"
- <|> reserved objc "CF_INLINE"
- t <- simple_type
- (n, tf) <- id_declarator
- skipBlock
- return []
+ <|> definedKeyword (\x -> "EXTERN" `isSuffixOf` x || "EXPORT"
`isSuffixOf` x)
+inline_keyword =
+ reserved objc "inline" <|> definedKeyword ("_INLINE" `isSuffixOf`)
+
+storage_class = extern_keyword <|> inline_keyword <|> reserved
objc "static"
-- Ignore __attribute__((...)) and Apple's countless different
availability macros,
-- which all expand to some __attribute__. My favourite example is
@@ -433,7 +470,7 @@
classOrInstanceMethod <-
(symbol objc "-" >> return InstanceMethod)
<|> (symbol objc "+" >> return ClassMethod)
- -- str <- many (satisfy (\c -> c /= ';' && c /= '@'))
+
rettype <- option (CTIDType []) (parens objc ctype)
(name,types,vararg) <- (
do
|
|
From: <cod...@go...> - 2008-10-08 00:00:22
|
Author: wol...@gm...
Date: Tue Oct 7 16:56:55 2008
New Revision: 335
Modified:
trunk/hoc/InterfaceGenerator2/Headers.hs
Log:
When collecting headers for a framework, include sub-frameworks
Modified: trunk/hoc/InterfaceGenerator2/Headers.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Headers.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Headers.hs Tue Oct 7 16:56:55 2008
@@ -13,7 +13,7 @@
import Data.Char(isAlphaNum, toUpper)
import Data.List(isPrefixOf,isSuffixOf)
import Data.Maybe(mapMaybe)
-import System.Directory(getDirectoryContents)
+import System.Directory(getDirectoryContents, doesDirectoryExist)
import System.Info(os)
import Text.Parsec( runParserT )
import Messages( runMessages )
@@ -43,9 +43,29 @@
prefix ++ "." ++ takeWhile (/= '.') fn)
| fn <- files, ".h" `isSuffixOf` fn {- , fn /= (prefix ++ ".h")
-} ]
+headersForFrameworkAt path framework
+ = do
+ haveHeaders <- doesDirectoryExist (path </> "Headers")
+ baseHeaders <- if haveHeaders then headersIn (path </> "Headers")
framework
+ else return []
+
+ haveFrameworks <- doesDirectoryExist (path </> "Frameworks")
+
+ moreHeaders <- if not haveFrameworks then return [] else do
+ contents <- getDirectoryContents (path </> "Frameworks")
+
+ fmap concat $ mapM (\fw ->
+ headersForFrameworkAt (path </> "Frameworks" </> fw)
+ (framework ++ "." ++ takeWhile
(/= '.') fw)
+ ) $ filter (".framework" `isSuffixOf`) contents
+ return $ baseHeaders ++ moreHeaders
+
headersForFramework prefix framework =
if System.Info.os == "darwin"
- then headersIn (prefix </> "System/Library/Frameworks" </>
(framework ++ ".framework") </> "Headers") framework
+ then do
+ let fwPath = prefix </> "System/Library/Frameworks"
+ </> (framework ++ ".framework")
+ headersForFrameworkAt fwPath framework
else headersIn ("/usr/lib/GNUstep/System/Library/Headers/" ++
framework ++ "/") framework
translateObjCImport imp = haskellizeModuleName $
|
|
From: <cod...@go...> - 2008-10-07 23:56:25
|
Author: wol...@gm...
Date: Tue Oct 7 16:55:09 2008
New Revision: 334
Modified:
trunk/hoc/InterfaceGenerator2/BuildEntities.hs
trunk/hoc/InterfaceGenerator2/Entities.hs
trunk/hoc/InterfaceGenerator2/Output.hs
trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
Log:
automatically import struct types
Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs Tue Oct 7 16:55:09 2008
@@ -223,8 +223,19 @@
eSrcPos = pos
}
) >> return ()
- makeEntity _modName (pos, Typedef (CTStruct _n2 _fields) _name)
- = return ()
+ makeEntity modName (pos, Typedef (CTStruct n2 fields) name)
+ = do
+ newEntity $ Entity {
+ eName = CName $ BS.pack name,
+ eHaskellName = getName name (nameToUppercase name),
+ eAlternateHaskellNames = [],
+ eInfo = StructEntity mbTag $ map
(UnconvertedType . fst) fields,
+ eModule = LocalModule modName,
+ eSrcPos = pos
+ }
+ return ()
+ where
+ mbTag = if n2 == "" then Nothing else Just n2
makeEntity _modName (pos, Typedef (CTUnion _n2 _fields) _name)
= return ()
makeEntity modName (pos, Typedef (CTEnum _n2 vals) name)
Modified: trunk/hoc/InterfaceGenerator2/Entities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Entities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Entities.hs Tue Oct 7 16:55:09 2008
@@ -57,6 +57,8 @@
ByteString {- import statements -}
ByteString {- text -}
+ | StructEntity (Maybe String) [HaskellValueType]
+
deriving ( Read, Show, Eq, Ord, Typeable, Data )
data Name
Modified: trunk/hoc/InterfaceGenerator2/Output.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Output.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Output.hs Tue Oct 7 16:55:09 2008
@@ -38,6 +38,8 @@
where
lowercaseNames = map (BS.pack . nameToLowercase .
BS.unpack . fst) values
+ StructEntity _ _ -> [eHaskellName e `BS.append` BS.pack "(..)"]
+
AdditionalCodeEntity _ exp _ _ -> exp
_ -> case eName e of
@@ -213,6 +215,23 @@
Anonymous -> text "declareAnonymousCEnum"
pprAssoc (n, v)
= parens (doubleQuotes (textBS n) <> comma <+> integer
v)
+
+ pprEntity e@(Entity { eInfo = StructEntity mbTag fields })
+ = char '$' <> parens (
+ declare <+> brackets (
+ hcat $ punctuate comma $ map pprType fields
+ )
+ )
+ where
+ declare = case eName e of
+ CName cname -> text "declareCStructWithTag"
+ <+> doubleQuotes (textBS cname)
+ <+> tag
+ tag = case mbTag of Nothing -> text "Prelude.Nothing"
+ Just t -> parens (text "Prelude.Just"
<+> doubleQuotes (text t))
+
+ pprType t = text "[t|" <+> pprVariableType ht <+> text "|]"
+ where ConvertedType ht _ = t
pprEntity e@(Entity { eInfo = AdditionalCodeEntity _ _ _ txt })
= textBS txt
Modified: trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs Tue Oct 7 16:55:09 2008
@@ -74,6 +74,7 @@
TypeSynonymEntity _ -> Just PlainTypeName
AdditionalTypeEntity -> Just PlainTypeName
EnumEntity _ _ -> Just PlainTypeName
+ StructEntity _ _ -> Just PlainTypeName
ClassEntity _ -> Just ClassTypeName
_ -> Nothing
|
|
From: <cod...@go...> - 2008-10-07 23:35:21
|
Author: wol...@gm...
Date: Tue Oct 7 16:35:02 2008
New Revision: 333
Modified:
trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs
Log:
bugfix: when removing superfluous selector instances,
distinguish between instance and factory methods.
@interface X
{
}
- foo; // -> instance Has_foo (X a)
- bar; // -> instance Has_bar (X a)
@end
@interface Y
{
}
- foo; // -> superfluous, no additional instance declaration
+ bar; // instance Has_bar (YClass a) -- used to be erroneously omitted
@end
Modified: trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs Tue Oct 7 16:35:02
2008
@@ -68,25 +68,25 @@
where
keepEntity entity
= case isInstance entity of
- Just (classID, adoptedID)
- | any (\s -> adoptedID `Set.member` instances s)
+ Just (classID, adopted)
+ | any (\s -> adopted `Set.member` instances s)
(clsTree Map.! classID)
-> False
_ -> True
isInstance (Entity { eName = ProtocolAdoptionName classID protoID
})
- = Just (classID, protoID)
+ = Just (classID, (protoID, False))
isInstance (Entity { eName = SelectorInstanceName classID selID
isFactory })
- = Just (classID, selID)
+ = Just (classID, (selID, isFactory))
isInstance _ = Nothing
- instances :: EntityID -> Set.Set EntityID
+ instances :: EntityID -> Set.Set (EntityID, Bool)
instances = fromMaybe Set.empty . flip Map.lookup instancesMap
instancesMap =
Map.fromListWith Set.union
- [ (classID, Set.singleton adoptedID)
- | Just (classID, adoptedID)
+ [ (classID, Set.singleton adopted)
+ | Just (classID, adopted)
<- map isInstance $ map snd $
entityPileToList entityPile ]
|
|
From: <cod...@go...> - 2008-10-07 23:26:18
|
Author: wol...@gm...
Date: Tue Oct 7 16:21:53 2008
New Revision: 332
Modified:
trunk/hoc/InterfaceGenerator2/BuildEntities.hs
Log:
Minor cleanup: use System.FilePath.</>
Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs Tue Oct 7 16:21:53 2008
@@ -20,6 +20,7 @@
import Data.List ( groupBy, isPrefixOf )
import Data.Maybe ( fromMaybe )
import System.Directory ( doesFileExist )
+import System.FilePath ( (</>) )
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
@@ -336,12 +337,12 @@
--
*****************************************************************************
loadAdditionalCode :: String -> [String] -> EntityPile -> IO EntityPile
-loadAdditionalCode additionalCodePath0 modNames entityPile
+loadAdditionalCode additionalCodePath modNames entityPile
= flip execStateT entityPile $ do
flip mapM_ modNames $ \modName -> do
let additionalCodeName
- = additionalCodePath -- ###
- ++ map (\c -> if c == '.' then '/' else c) modName
+ = additionalCodePath
+ </> map (\c -> if c == '.' then '/' else c) modName
++ ".hs"
exists <- lift $ doesFileExist additionalCodeName
@@ -387,7 +388,3 @@
eSrcPos = AutoGeneratedPos
}
return ()
- where
- additionalCodePath
- | last additionalCodePath0 == '/' = additionalCodePath0
- | otherwise = additionalCodePath0 ++ "/"
|
|
From: <cod...@go...> - 2008-10-07 23:09:10
|
Author: wol...@gm...
Date: Tue Oct 7 16:07:50 2008
New Revision: 331
Added:
trunk/hoc/HOC/HOC/CStruct.hs
Modified:
trunk/hoc/HOC.cabal
trunk/hoc/HOC/HOC.hs
Log:
Add a template function for marshalling structs.
Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal (original)
+++ trunk/hoc/HOC.cabal Tue Oct 7 16:07:50 2008
@@ -44,7 +44,8 @@
HOC.TH,
HOC.Unicode,
HOC.Utilities,
- HOC.THDebug
+ HOC.THDebug,
+ HOC.CStruct
hs-source-dirs: HOC
extensions: MagicHash, TemplateHaskell,
Modified: trunk/hoc/HOC/HOC.hs
==============================================================================
--- trunk/hoc/HOC/HOC.hs (original)
+++ trunk/hoc/HOC/HOC.hs Tue Oct 7 16:07:50 2008
@@ -55,6 +55,9 @@
WrappedNSException(..),
+ declareCStruct,
+ declareCStructWithTag,
+
-- debugging & statistics:
objectMapStatistics
@@ -81,3 +84,4 @@
import HOC.Selectors
import HOC.Exception
import HOC.FFICallInterface
+import HOC.CStruct
Added: trunk/hoc/HOC/HOC/CStruct.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/HOC/HOC/CStruct.hs Tue Oct 7 16:07:50 2008
@@ -0,0 +1,133 @@
+{-# OPTIONS -fglasgow-exts -fth #-}
+module HOC.CStruct( declareCStruct, declareCStructWithTag ) where
+
+import HOC.Arguments ( ObjCArgument(..) )
+import HOC.TH
+import HOC.NameCaseChange ( nameToUppercase )
+import HOC.FFICallInterface
+
+import Control.Monad.State
+import Data.Bits
+import Data.Maybe ( fromMaybe )
+import Foreign
+
+declareCStruct :: String -> [TypeQ] -> Q [Dec]
+declareCStructWithTag :: String -> Maybe String -> [TypeQ] -> Q [Dec]
+
+
+mkRawThing :: ObjCArgument a b => a -> b
+mkRawThing _ = undefined
+
+sizeMember :: ObjCArgument a b => a -> State Int ()
+sizeMember thing =
+ modify (\offset -> align offset (alignment rawThing) + sizeOf rawThing)
+
+ where align x a = (x + (a-1)) .&. complement (a-1)
+ rawThing = mkRawThing thing
+
+alignMember :: ObjCArgument a b => a -> Int
+alignMember = alignment . mkRawThing
+
+pokeMember :: ObjCArgument a b => a -> StateT (Ptr c) IO ()
+pokeMember thing = do
+ rawThing <- lift $ exportArgument thing
+ modify (`alignPtr` alignment rawThing)
+ p <- get
+ lift $ poke (castPtr p) rawThing
+ modify (`plusPtr` sizeOf rawThing)
+
+peekMember :: ObjCArgument a b => StateT (Ptr c) IO a
+peekMember = (mfix $ \result -> do
+ modify (`alignPtr` alignment result)
+ p <- get
+ rawThing <- lift $ peek (castPtr p)
+ modify (`plusPtr` sizeOf rawThing)
+ return rawThing) >>= \rawThing -> lift (importArgument rawThing)
+
+ffiMember :: ObjCArgument a b => a -> StateT [FFIType] IO ()
+ffiMember thing = do
+ t <- lift $ makeFFIType (mkRawThing thing)
+ modify (t :)
+
+
+declareCStruct cname fieldTypes
+ = declareCStructWithTag cname Nothing fieldTypes
+
+declareCStructWithTag cname mbTag fieldTypes
+ = do
+ let name = mkName $ nameToUppercase cname
+ structTag = fromMaybe "?" mbTag
+ dataDecl <- dataD (cxt []) name [] [
+ normalC name $
+ map (strictType (return NotStrict)) fieldTypes
+ ] [''Eq, ''Ord] --, ''Read, ''Show]
+
+ varNames <- mapM (const $ newName "field") fieldTypes
+ ptrName <- newName "ptr"
+
+ let takeApartP = conP name $ map varP varNames
+ putTogetherE | null varNames = conE name
+ | otherwise = appsE $ (conE name : map varE
varNames)
+
+ doWithArgs name | null varNames = [| return () |]
+ doWithArgs name = doE $
+ [ noBindS (varE name `appE` varE field)
+ | field <- varNames ]
+
+ doWithResults name = doE $
+ [ bindS (varP field) (varE name)
+ | field <- varNames ]
+ ++ [ noBindS [| return $(putTogetherE) |] ]
+
+ mapArgs name = listE $
+ [ varE name `appE` varE field | field <- varNames ]
+
+ storableDecl <- instanceD (cxt []) (conT ''Storable `appT` conT
name)
+ [
+ funD 'alignment [
+ clause [tildeP takeApartP]
+ (normalB [| maximum ( 1 : $(mapArgs 'alignMember)
) |]) []
+ ],
+ funD 'sizeOf [
+ clause [tildeP takeApartP]
+ (normalB [| execState $(doWithArgs 'sizeMember) 0 |
])
+ []
+ ],
+ funD 'poke [
+ clause [varP ptrName, takeApartP]
+ (normalB [| evalStateT $(doWithArgs 'pokeMember)
$(varE ptrName) |])
+ []
+ ],
+ funD 'peek [
+ clause [varP ptrName]
+ (normalB [| evalStateT
$(doWithResults 'peekMember) $(varE ptrName) |])
+ []
+ ]
+ ]
+
+ ffiDecl <- instanceD (cxt []) (conT ''FFITypeable `appT` conT name)
+ [
+ funD 'isStructType [ clause [wildP] (normalB [| True |])
[] ],
+ funD 'makeFFIType [
+ clause [tildeP takeApartP]
+ (normalB [| execStateT $(doWithArgs 'ffiMember) []
+ >>= makeStructType . reverse |])
+ []
+ ]
+ ]
+
+ argDecl <- instanceD (cxt []) (conT ''ObjCArgument `appT`
+ conT name `appT` conT name)
+ [
+ valD (varP 'exportArgument) (normalB [| return |]) [],
+ valD (varP 'importArgument) (normalB [| return |]) [],
+ funD 'objCTypeString [
+ clause [tildeP takeApartP]
+ (normalB [| "{" ++ structTag ++ "=" ++
+ concat $(mapArgs 'objCTypeString) ++
+ "}" |])
+ []
+ ]
+ ]
+
+ return [dataDecl, storableDecl, ffiDecl, argDecl]
|
|
From: <cod...@go...> - 2008-10-07 23:05:09
|
Author: wol...@gm...
Date: Tue Oct 7 16:04:51 2008
New Revision: 330
Modified:
trunk/hoc/HOC/HOC/CEnum.hs
Log:
Clarify a comment.
Modified: trunk/hoc/HOC/HOC/CEnum.hs
==============================================================================
--- trunk/hoc/HOC/HOC/CEnum.hs (original)
+++ trunk/hoc/HOC/HOC/CEnum.hs Tue Oct 7 16:04:51 2008
@@ -30,8 +30,9 @@
-- name1 = Name1
-- name2 = Name2
-- ...
---where all the names are more or less transformed by mkName .
nameToUppercase
---I don't know why there is both the constructors and the literal names.
+-- where all the names are more or less transformed by mkName .
nameToUppercase
+-- Constants (with lowercase names) are also provided for people who want
to
+-- hide the difference between "proper" enums and anonymous enums (see
below).
declareCEnum name assocs
= sequence $ [
|
|
From: <cod...@go...> - 2008-10-07 22:37:27
|
Author: wol...@gm...
Date: Tue Oct 7 15:14:47 2008
New Revision: 329
Modified:
trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
Log:
Make enum names hack less aggressive -- do not combine anonymous enums with
int (long/unsigned/etc.) typedefs that follow.
Modified: trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/HackEnumNames.hs (original)
+++ trunk/hoc/InterfaceGenerator2/HackEnumNames.hs Tue Oct 7 15:14:47 2008
@@ -6,15 +6,14 @@
hackEnumNames :: HeaderInfo -> HeaderInfo
-hackEnumNames (HeaderInfo name imports decls)
- = HeaderInfo name imports (hackEnums1 Just id decls)
+hackEnumNames (HeaderInfo headerName imports decls)
+ = HeaderInfo headerName imports (hackEnums1 Just id decls)
where
hackEnums1 :: (a -> Maybe DeclarationAndPos) -> (DeclarationAndPos
-> a) -> [a] -> [a]
hackEnums1 unwrap wrap (x : y : xs)
| Just (pos, CTypeDecl (CTEnum name1 vals)) <- unwrap x,
Just (_, Typedef baseType name2) <- unwrap y,
- null name1 || name1 == name2 || name1 == '_' : name2,
- acceptableEnumBaseType baseType
+ null name1 && acceptableEnumBaseType name2 baseType ||
acceptableEnumTag name1 name2
= wrap (pos, Typedef (CTEnum name1 vals) name2)
: hackEnums1 unwrap wrap xs
hackEnums1 unwrap wrap (x : xs)
@@ -28,8 +27,9 @@
decl (pos, d) = (pos, LocalDecl d)
hackEnums1 unwrap wrap [] = []
- acceptableEnumBaseType (CTSimple name)
+ acceptableEnumBaseType name2 (CTSimple name)
| name == "NSInteger" || name == "NSUInteger" = True
- acceptableEnumBaseType (CTBuiltin _ _ name)
- | name == "int" = True
- acceptableEnumBaseType _ = False
+ acceptableEnumBaseType _ _ = False
+
+ acceptableEnumTag name1 name2
+ = dropWhile (== '_') name1 == name2
|
|
From: <cod...@go...> - 2008-10-01 23:16:37
|
Author: wol...@gm...
Date: Wed Oct 1 16:15:31 2008
New Revision: 328
Modified:
trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
Log:
Improve messages for zapped entities.
Less is more.
Modified: trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs Wed Oct 1 16:15:31 2008
@@ -77,7 +77,7 @@
ClassEntity _ -> Just ClassTypeName
_ -> Nothing
-zapAndReportWith :: ((EntityID, Entity) -> Messages (EntityID, Entity))
+zapAndReportWith :: ((EntityID, Entity) -> StateT Bool Messages (EntityID,
Entity))
-> ProgressReporter
-> EntityPile -> Messages EntityPile
zapAndReportWith worker progress entityPile
@@ -88,16 +88,35 @@
fmap (Map.fromList . catMaybes) $
flip mapM (map (monitor1 progress 0) $ Map.toList $
localEntities entityPile) $
\(entityID, entity) ->
- case runMessages $ worker (entityID, entity) of
- (x, [])
+ case runMessages $ runStateT (worker (entityID, entity))
False of
+ ( (x, False), _)
-> return $ Just x
- (_, messages)
+ ( (x, True), messages)
-> do
- message (pprSourcePos (eSrcPos entity)
- <> text ": Skipping"
- <+> (text.show) entityID
- <+> parens (text $ show $ eName
entity)
- $+$ nest 4 (vcat messages))
+ case eInfo entity of
+ ReexportEntity _ -> return ()
+ MethodEntity -> return ()
+ ProtocolAdoptionEntity -> return ()
+ _ ->
+ let kind = text $ case eInfo entity of
+ ClassEntity _ -> "class"
+ TypeSynonymEntity _
-> "typedef"
+ EnumEntity _ _ -> "enum"
+ SelectorEntity _ -> "selector"
+ ProtocolEntity _ _
-> "protocol"
+ ExternVarEntity _
-> "variable/constant"
+ ExternFunEntity _ -> "function"
+ _ -> ""
+ name = text $ case eName entity of
+ CName s -> BS.unpack s
+ ProtocolName s -> BS.unpack s
+ SelectorName s -> BS.unpack s
+ _ -> "<anonymous>"
+ in message (pprSourcePos (eSrcPos
entity)
+ <> text ": Skipping"
+ <+> kind <+> name
+ <+> (parens.text.show)
entityID
+ $+$ nest 4 (vcat messages))
return Nothing
let pile' = replaceLocalEntities entities' entityPile
case messages of
@@ -114,7 +133,9 @@
>> return x
reportUnconvertedType t@(UnconvertedType ctype)
- = message $ text "Coudn't convert type" <+> text (show ctype)
+ = do
+ lift $ message $ text "Coudn't convert type." -- <+> text
(show ctype)
+ put True
reportUnconvertedType t
= return ()
@@ -137,5 +158,6 @@
return (entityID, entity')
reportBrokenRef eid
- = unless (hasEntity eid entityPile) $
- message $ text (show eid) <+> text "has been deleted."
+ = unless (hasEntity eid entityPile) $ do
+ lift $ message $ text (show eid) <+> text "has been
deleted."
+ put True
\ No newline at end of file
|
|
From: <cod...@go...> - 2008-10-01 22:54:29
|
Author: wol...@gm...
Date: Wed Oct 1 15:53:54 2008
New Revision: 327
Added:
trunk/hoc/InterfaceGenerator2/SrcPos.hs
Modified:
trunk/hoc/InterfaceGenerator2/BuildEntities.hs
trunk/hoc/InterfaceGenerator2/Entities.hs
trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
trunk/hoc/InterfaceGenerator2/Headers.hs
trunk/hoc/InterfaceGenerator2/Parser.hs
trunk/hoc/InterfaceGenerator2/ParserBase.hs
trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs
trunk/hoc/InterfaceGenerator2/SyntaxTree.hs
Log:
Add source location information to parse tree and entity pile.
Use it when reporting skipped entities.
Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs Wed Oct 1 15:53:54 2008
@@ -8,6 +8,7 @@
import Traversals
import BindingScript
import SyntaxTree
+import SrcPos
import CTypeToHaskell
import Headers
@@ -17,7 +18,7 @@
import Control.Monad.State
import Data.Char ( isUpper, isLower, isAlphaNum, toUpper )
import Data.List ( groupBy, isPrefixOf )
-import Data.Maybe ( fromMaybe, catMaybes )
+import Data.Maybe ( fromMaybe )
import System.Directory ( doesFileExist )
import qualified Data.ByteString.Char8 as BS
@@ -60,7 +61,8 @@
eHaskellName = assertHaskellTypeName $ BS.pack
typeName,
eAlternateHaskellNames = [],
eInfo = AdditionalTypeEntity,
- eModule = LocalModule $ BS.pack moduleName
+ eModule = LocalModule $ BS.pack moduleName,
+ eSrcPos = AutoGeneratedPos
}
| (typeName, moduleName) <- bsAdditionalTypes
bindingScript,
BS.pack moduleName `Set.member` modNames
@@ -87,7 +89,7 @@
-- Workaround: If there is both an instance method and a class
method of the
-- same name, don't use covariant.
- makeSelectorEntity factory modName _clsID clsName sel
+ makeSelectorEntity pos factory modName _clsID clsName sel
= if hidden
then return []
else do
@@ -96,7 +98,8 @@
eHaskellName = BS.pack mangled,
eAlternateHaskellNames = moreMangled,
eInfo = SelectorEntity (UnconvertedType (kind,
sel')),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return $ [(entity, factory)]
where
@@ -129,16 +132,16 @@
&& (not $ isLower (b !! length a))
| otherwise = a == b
- makeEntitiesForSelectorListItem modName clsID clsName
(InstanceMethod sel)
- = makeSelectorEntity False modName clsID clsName sel
- makeEntitiesForSelectorListItem modName clsID clsName (ClassMethod
sel)
- = makeSelectorEntity True modName clsID clsName sel
- makeEntitiesForSelectorListItem modName _clsID _clsName (LocalDecl
decl)
- = makeEntity modName decl >> return []
- makeEntitiesForSelectorListItem modName clsID clsName
(PropertyDecl typ name attr)
+ makeEntitiesForSelectorListItem modName clsID clsName (pos,
InstanceMethod sel)
+ = makeSelectorEntity pos False modName clsID clsName sel
+ makeEntitiesForSelectorListItem modName clsID clsName (pos,
ClassMethod sel)
+ = makeSelectorEntity pos True modName clsID clsName sel
+ makeEntitiesForSelectorListItem modName _clsID _clsName (pos,
LocalDecl decl)
+ = makeEntity modName (pos, decl) >> return []
+ makeEntitiesForSelectorListItem modName clsID clsName (pos,
PropertyDecl typ name attr)
= do
- getter <- makeSelectorEntity False modName clsID clsName
getterSel
- setter <- makeSelectorEntity False modName clsID clsName
setterSel
+ getter <- makeSelectorEntity pos False modName clsID
clsName getterSel
+ setter <- makeSelectorEntity pos False modName clsID
clsName setterSel
return (getter ++ setter)
where
getterName = head $ [ n | Getter n <- attr ] ++ [ name ]
@@ -147,23 +150,24 @@
getterSel = Selector getterName typ [] False
setterSel = Selector setterName
(CTSimple "void") [typ] False
- makeEntitiesForSelectorListItem _modName _clsID _clsName (Required
_)
+ makeEntitiesForSelectorListItem _modName _clsID _clsName (pos,
Required _)
= return []
makeSelectorEntities modName clsID clsName items
= fmap concat $
mapM (makeEntitiesForSelectorListItem modName clsID clsName)
items
- makeSelectorInstance modName classEntity (selectorEntity, factory)
+ makeSelectorInstance pos modName classEntity (selectorEntity,
factory)
= newEntity $ Entity {
eName = SelectorInstanceName classEntity
selectorEntity factory,
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = MethodEntity,
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
- makeEntity modName (SelectorList (Interface clsName mbSuper
protocols) contents)
+ makeEntity modName (pos, SelectorList (Interface clsName mbSuper
protocols) contents)
| notHidden clsName
= do
classEntity <- newEntity $ Entity {
@@ -171,7 +175,8 @@
eHaskellName = getName clsName (nameToUppercase
clsName),
eAlternateHaskellNames = [],
eInfo = ClassEntity (fmap (DelayedClassLookup .
BS.pack) mbSuper),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
flip mapM_ protocols $ \protocol ->
newEntity $ Entity {
@@ -180,12 +185,13 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
selectors <- makeSelectorEntities modName classEntity
clsName contents
- mapM (makeSelectorInstance modName classEntity) selectors
+ mapM (makeSelectorInstance pos modName classEntity)
selectors
return ()
- makeEntity modName (SelectorList (Category clsName _catName
protocols) contents)
+ makeEntity modName (pos, SelectorList (Category clsName _catName
protocols) contents)
= do
let classEntity = DelayedClassLookup $ BS.pack clsName
flip mapM_ protocols $ \protocol ->
@@ -195,12 +201,13 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
selectors <- makeSelectorEntities modName classEntity
clsName contents
- mapM (makeSelectorInstance modName classEntity) selectors
+ mapM (makeSelectorInstance pos modName classEntity)
selectors
return ()
- makeEntity modName (SelectorList (Protocol protoName protocols)
contents)
+ makeEntity modName (pos, SelectorList (Protocol protoName
protocols) contents)
| notHidden protoName
= mfix (\protocolEntity -> do
selectors <- fmap (map fst) $ makeSelectorEntities modName
@@ -211,22 +218,22 @@
eAlternateHaskellNames = [],
eInfo = ProtocolEntity (map
(DelayedProtocolLookup . BS.pack) protocols)
selectors,
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
) >> return ()
- makeEntity _modName (Typedef (CTStruct _n2 _fields) _name)
+ makeEntity _modName (pos, Typedef (CTStruct _n2 _fields) _name)
= return ()
- makeEntity _modName (Typedef (CTUnion _n2 _fields) _name)
+ makeEntity _modName (pos, Typedef (CTUnion _n2 _fields) _name)
= return ()
- makeEntity modName (Typedef (CTEnum _n2 vals) name)
+ makeEntity modName (pos, Typedef (CTEnum _n2 vals) name)
| notHidden name
- = makeEnum name modName vals
- -- makeAnonymousEnum modName vals -- ### HACK for 10.5:
ignore enum names
- makeEntity modName (CTypeDecl (CTEnum name vals))
+ = makeEnum name pos modName vals
+ makeEntity modName (pos, CTypeDecl (CTEnum name vals))
| null name || notHidden name
- = (if null name {- || True {- ### see above -}-} then
makeAnonymousEnum else makeEnum name) modName vals
+ = (if null name then makeAnonymousEnum else makeEnum name) pos
modName vals
- makeEntity modName (Typedef ct name)
+ makeEntity modName (pos, Typedef ct name)
| notHidden name
= do
newEntity $ Entity {
@@ -234,10 +241,11 @@
eHaskellName = getName name (nameToUppercase name),
eAlternateHaskellNames = [],
eInfo = TypeSynonymEntity (UnconvertedType ct),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
- makeEntity modName (ExternVar ct name)
+ makeEntity modName (pos, ExternVar ct name)
| notHidden name
= do
newEntity $ Entity {
@@ -245,10 +253,11 @@
eHaskellName = getName name (nameToLowercase name),
eAlternateHaskellNames = [],
eInfo = ExternVarEntity (UnconvertedType ct),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
- makeEntity modName (ExternFun sel)
+ makeEntity modName (pos, ExternFun sel)
| notHidden name
= do
newEntity $ Entity {
@@ -256,7 +265,8 @@
eHaskellName = getName name (nameToLowercase name),
eAlternateHaskellNames = [],
eInfo = ExternFunEntity (UnconvertedType
(PlainSelector, sel)),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
where name = selName sel
@@ -278,7 +288,7 @@
= convert Nothing xs
convert _ [] = []
- makeEnum name modName values
+ makeEnum name pos modName values
= case convertEnumEntities values of
(True, values') -> do
newEntity $ Entity {
@@ -286,7 +296,8 @@
eHaskellName = getName name (nameToUppercase
name),
eAlternateHaskellNames = [],
eInfo = EnumEntity True values',
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
(False, values') -> do
@@ -295,17 +306,19 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = EnumEntity False values',
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToUppercase
name),
eAlternateHaskellNames = [],
eInfo = TypeSynonymEntity (UnconvertedType
cTypeInt),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
- makeAnonymousEnum modName values
+ makeAnonymousEnum pos modName values
= do
let (complete, values') = convertEnumEntities values
newEntity $ Entity {
@@ -313,7 +326,8 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = EnumEntity complete values',
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
@@ -357,7 +371,8 @@
exports
imports2
above,
- eModule = LocalModule $ BS.pack modName
+ eModule = LocalModule $ BS.pack modName,
+ eSrcPos = AutoGeneratedPos
}
newEntity $ Entity {
eName = Anonymous,
@@ -368,7 +383,8 @@
[]
imports1
below,
- eModule = LocalModule $ BS.pack modName
+ eModule = LocalModule $ BS.pack modName,
+ eSrcPos = AutoGeneratedPos
}
return ()
where
Modified: trunk/hoc/InterfaceGenerator2/Entities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Entities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Entities.hs Wed Oct 1 15:53:54 2008
@@ -1,4 +1,4 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
module Entities where
import Control.Monad.State
@@ -10,6 +10,7 @@
import CTypeToHaskell
import SyntaxTree ( CType, Selector )
import Progress
+import SrcPos( SrcPos )
import Data.ByteString.Char8(ByteString)
import qualified Data.ByteString.Char8 as BS
@@ -77,7 +78,8 @@
eHaskellName :: ByteString,
eAlternateHaskellNames :: [ByteString],
eInfo :: EntityInfo,
- eModule :: Module
+ eModule :: Module,
+ eSrcPos :: SrcPos
}
deriving ( Read, Show, Typeable, Data )
Modified: trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/HackEnumNames.hs (original)
+++ trunk/hoc/InterfaceGenerator2/HackEnumNames.hs Wed Oct 1 15:53:54 2008
@@ -9,22 +9,23 @@
hackEnumNames (HeaderInfo name imports decls)
= HeaderInfo name imports (hackEnums1 Just id decls)
where
- hackEnums1 :: (a -> Maybe Declaration) -> (Declaration -> a) ->
[a] -> [a]
+ hackEnums1 :: (a -> Maybe DeclarationAndPos) -> (DeclarationAndPos
-> a) -> [a] -> [a]
hackEnums1 unwrap wrap (x : y : xs)
- | Just (CTypeDecl (CTEnum name1 vals)) <- unwrap x,
- Just (Typedef baseType name2) <- unwrap y,
+ | Just (pos, CTypeDecl (CTEnum name1 vals)) <- unwrap x,
+ Just (_, Typedef baseType name2) <- unwrap y,
null name1 || name1 == name2 || name1 == '_' : name2,
acceptableEnumBaseType baseType
- = wrap (Typedef (CTEnum name1 vals) name2)
+ = wrap (pos, Typedef (CTEnum name1 vals) name2)
: hackEnums1 unwrap wrap xs
hackEnums1 unwrap wrap (x : xs)
- | Just (SelectorList header items) <- unwrap x
- = wrap (SelectorList header (hackEnums1 decl LocalDecl items))
+ | Just (pos, SelectorList header items) <- unwrap x
+ = wrap (pos, SelectorList header (hackEnums1 undecl decl
items))
: hackEnums1 unwrap wrap xs
| otherwise
= x : hackEnums1 unwrap wrap xs
- where decl (LocalDecl d) = Just d
- decl other = Nothing
+ where undecl (pos, LocalDecl d) = Just (pos, d)
+ undecl other = Nothing
+ decl (pos, d) = (pos, LocalDecl d)
hackEnums1 unwrap wrap [] = []
acceptableEnumBaseType (CTSimple name)
Modified: trunk/hoc/InterfaceGenerator2/Headers.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Headers.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Headers.hs Wed Oct 1 15:53:54 2008
@@ -6,12 +6,12 @@
import Parser(header)
import ParserBase(emptyParseEnvironment)
-import SyntaxTree(Declaration)
+import SyntaxTree(ParsedHeader)
import Control.Exception(evaluate)
import Control.Monad(when)
import Data.Char(isAlphaNum, toUpper)
-import Data.List(isPrefixOf,isSuffixOf,partition)
+import Data.List(isPrefixOf,isSuffixOf)
import Data.Maybe(mapMaybe)
import System.Directory(getDirectoryContents)
import System.Info(os)
@@ -27,7 +27,7 @@
import qualified Data.Map as Map
type ModuleName = ByteString
-data HeaderInfo = HeaderInfo ModuleName [ModuleName] [Declaration]
+data HeaderInfo = HeaderInfo ModuleName [ModuleName] ParsedHeader
deriving(Show)
findImports = mapMaybe checkImport . lines
Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs Wed Oct 1 15:53:54 2008
@@ -1,23 +1,21 @@
{-# 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 Data.Maybe ( isJust, fromJust )
+import Data.Char ( ord, isUpper, isDigit )
+import Data.Bits ( shiftL, (.|.) )
+import Control.Monad ( guard )
import Text.Parsec
import Text.Parsec.Token
-import Text.Parsec.Language(emptyDef)
import Text.Parsec.Expr
import SyntaxTree
-
-import qualified Data.Map as Map
-
+import SrcPos
import ParserBase
+
objcDef = LanguageDef
{ commentStart = "/*"
, commentEnd = "*/"
@@ -40,15 +38,16 @@
singleton x = [x]
-header :: Parser [Declaration]
+header :: Parser ParsedHeader
header = do
optional (whiteSpace objc)
things <- fmap concat $ many $ do
+ pos <- getPosition
-- thing <- try interestingThing <|> uninterestingThing -- lenient
parsing
- thing <- interestingThing -- strict parsing
+ things <- interestingThing -- strict parsing
optional (whiteSpace objc)
- return thing
+ return $ map (\thing -> (parsecPosToSrcPos pos, thing)) things
eof
return things
@@ -397,7 +396,10 @@
return $ Interface class_name super protos
)
instance_variables
- selectors <- fmap concat $ many selectorListItem
+ selectors <- fmap concat $ many $ do
+ pos <- getPosition
+ items <- selectorListItem
+ return $ map (\item -> (parsecPosToSrcPos pos, item)) items
reserved objc "@end"
return [SelectorList what selectors]
where
Modified: trunk/hoc/InterfaceGenerator2/ParserBase.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ParserBase.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ParserBase.hs Wed Oct 1 15:53:54 2008
@@ -6,7 +6,7 @@
import Control.Monad.Trans( lift )
import Messages
import qualified Text.PrettyPrint.HughesPJ as PP
-
+import SrcPos
type ParseEnvironment = Map.Map String Integer
@@ -30,5 +30,6 @@
parseWarning msg
= do
pos <- getPosition
- lift (message $ PP.text (show pos ++ ": " ++ msg))
+ lift (message $ pprSourcePos (parsecPosToSrcPos pos)
+ PP.<> PP.text (": " ++ msg))
Modified: trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs Wed Oct 1 15:53:54 2008
@@ -4,6 +4,7 @@
import Traversals
import CTypeToHaskell
import Messages
+import SrcPos
import Progress
import Control.Monad.State
@@ -92,7 +93,8 @@
-> return $ Just x
(_, messages)
-> do
- message (text "Skipping"
+ message (pprSourcePos (eSrcPos entity)
+ <> text ": Skipping"
<+> (text.show) entityID
<+> parens (text $ show $ eName
entity)
$+$ nest 4 (vcat messages))
Modified: trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs Wed Oct 1 15:53:54
2008
@@ -39,7 +39,8 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = MethodEntity,
- eModule = eModule entity
+ eModule = eModule entity,
+ eSrcPos = eSrcPos entity
}
addProto proto
@@ -48,7 +49,8 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
- eModule = eModule entity
+ eModule = eModule entity,
+ eSrcPos = eSrcPos entity
}
_ -> return ()
Added: trunk/hoc/InterfaceGenerator2/SrcPos.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/InterfaceGenerator2/SrcPos.hs Wed Oct 1 15:53:54 2008
@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module SrcPos where
+
+import Data.Generics
+import Text.PrettyPrint.HughesPJ
+import Text.Parsec( sourceName, sourceLine, sourceColumn )
+
+data SrcPos = SrcPos String Int Int
+ | AutoGeneratedPos
+ deriving ( Read, Show, Eq, Ord, Typeable, Data )
+
+pprSourcePos (SrcPos file line col)
+ = text file <> char ':' <> int line <> char ':' <> int col
+pprSourcePos AutoGeneratedPos
+ = text "<generated>"
+
+parsecPosToSrcPos s = SrcPos (sourceName s) (sourceLine s) (sourceColumn s)
Modified: trunk/hoc/InterfaceGenerator2/SyntaxTree.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/SyntaxTree.hs (original)
+++ trunk/hoc/InterfaceGenerator2/SyntaxTree.hs Wed Oct 1 15:53:54 2008
@@ -1,17 +1,22 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE DeriveDataTypeable #-}
module SyntaxTree where
import Data.Generics
+import SrcPos
+
+type ParsedHeader = [ DeclarationAndPos ]
data Declaration =
ForwardClass [String]
| ForwardProtocol [String]
- | SelectorList SelectorListHeader [SelectorListItem]
+ | SelectorList SelectorListHeader [(SrcPos, SelectorListItem)]
| Typedef CType String
| CTypeDecl CType
| ExternVar CType String
| ExternFun Selector
deriving (Show,Eq,Ord)
+
+type DeclarationAndPos = (SrcPos, Declaration)
data SelectorListHeader =
Interface String (Maybe String) [String]
|
|
From: <cod...@go...> - 2008-10-01 22:06:25
|
Author: wol...@gm...
Date: Wed Oct 1 14:40:28 2008
New Revision: 324
Modified:
trunk/hoc/InterfaceGenerator2/BinaryInstances.hs
Log:
Re-implement BinaryInstances using Data.Generics. Much more fun this way.
Modified: trunk/hoc/InterfaceGenerator2/BinaryInstances.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BinaryInstances.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BinaryInstances.hs Wed Oct 1 14:40:28
2008
@@ -1,183 +1,78 @@
-module BinaryInstances where
+{-# LANGUAGE PatternGuards, PatternSignatures, ExistentialQuantification
#-}
+module BinaryInstances() where
-import Entities
-import SyntaxTree
-import CTypeToHaskell
import Data.Binary
+import Data.Generics
+import Control.Monad.Fix ( mfix )
+import Control.Monad ( msum )
+import Data.ByteString.Char8 ( ByteString )
+import Data.Maybe ( fromJust, fromMaybe )
+
+import Entities
+data BinaryType = forall a. (Binary a, Typeable a) => BinaryType a
-instance Binary SyntaxTree.EnumValue where
- put NextValue = putWord8 0
- put (GivenValue a) = putWord8 1 >> put a
- put (TooComplicatedValue a) = putWord8 2 >> put a
- get = do
- tag_ <- getWord8
- case tag_ of
- 0 -> return NextValue
- 1 -> get >>= \a -> return (GivenValue a)
- 2 -> get >>= \a -> return (TooComplicatedValue a)
- _ -> fail "no parse"
-
-instance Binary SyntaxTree.CType where
- put (CTIDType a) = putWord8 0 >> put a
- put (CTSimple a) = putWord8 1 >> put a
- put (CTPointer a) = putWord8 2 >> put a
- put CTUnknown = putWord8 3
- put (CTEnum a b) = putWord8 4 >> put a >> put b
- put (CTStruct a b) = putWord8 5 >> put a >> put b
- put (CTUnion a b) = putWord8 6 >> put a >> put b
- put (CTBuiltin a b c) = putWord8 7 >> put a >> put b >> put c
- get = do
- tag_ <- getWord8
- case tag_ of
- 0 -> get >>= \a -> return (CTIDType a)
- 1 -> get >>= \a -> return (CTSimple a)
- 2 -> get >>= \a -> return (CTPointer a)
- 3 -> return CTUnknown
- 4 -> get >>= \a -> get >>= \b -> return (CTEnum a b)
- 5 -> get >>= \a -> get >>= \b -> return (CTStruct a b)
- 6 -> get >>= \a -> get >>= \b -> return (CTUnion a b)
- 7 -> get >>= \a -> get >>= \b -> get >>= \c -> return (CTBuiltin a b
c)
- _ -> fail "no parse"
-
-instance Binary SyntaxTree.Length where
- put LongLong = putWord8 0
- put Long = putWord8 1
- put Short = putWord8 2
- get = do
- tag_ <- getWord8
- case tag_ of
- 0 -> return LongLong
- 1 -> return Long
- 2 -> return Short
- _ -> fail "no parse"
-
-instance Binary SyntaxTree.Selector where
- put (Selector a b c d) = put a >> put b >> put c >> put d
- get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return
(Selector a b c d)
-
-instance Binary CTypeToHaskell.HSelectorType where
- put (HSelectorType a b c d) = put a >> put b >> put c >> put d
- get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return
(HSelectorType a b c d)
-
-instance Binary CTypeToHaskell.HType where
- put (HType a b c) = put a >> put b >> put c
- get = get >>= \a -> get >>= \b -> get >>= \c -> return (HType a b c)
-
-instance Binary CTypeToHaskell.HTypeTerm where
- put (Con a) = putWord8 0 >> put a
- put (a :$ b) = putWord8 1 >> put a >> put b
- put (Var a) = putWord8 2 >> put a
- get = do
- tag_ <- getWord8
- case tag_ of
- 0 -> get >>= \a -> return (Con a)
- 1 -> get >>= \a -> get >>= \b -> return (a :$ b)
- 2 -> get >>= \a -> return (Var a)
- _ -> fail "no parse"
-
-instance Binary Entities.EntityID where
- put (LocalEntity a) = putWord8 0 >> put a
- put (FrameworkEntity a b) = putWord8 1 >> put a >> put b
- put (DelayedClassLookup a) = putWord8 2 >> put a
- put (DelayedProtocolLookup a) = putWord8 3 >> put a
- get = do
- tag_ <- getWord8
- case tag_ of
- 0 -> get >>= \a -> return (LocalEntity a)
- 1 -> get >>= \a -> get >>= \b -> return (FrameworkEntity a b)
- 2 -> get >>= \a -> return (DelayedClassLookup a)
- 3 -> get >>= \a -> return (DelayedProtocolLookup a)
- _ -> fail "no parse"
-
-instance Binary Entities.Module where
- put (LocalModule a) = putWord8 0 >> put a
- put (FrameworkModule a b) = putWord8 1 >> put a >> put b
- get = do
- tag_ <- getWord8
- case tag_ of
- 0 -> get >>= \a -> return (LocalModule a)
- 1 -> get >>= \a -> get >>= \b -> return (FrameworkModule a b)
- _ -> fail "no parse"
-
-instance (Binary a, Binary b) => Binary (Entities.HaskellType a b) where
- put (ConvertedType a b) = putWord8 0 >> put a >> put b
- put (UnconvertedType a) = putWord8 1 >> put a
- get = do
- tag_ <- getWord8
- case tag_ of
- 0 -> get >>= \a -> get >>= \b -> return (ConvertedType a b)
- 1 -> get >>= \a -> return (UnconvertedType a)
- _ -> fail "no parse"
-
-instance Binary Entities.EntityInfo where
- put (ClassEntity a) = putWord8 0 >> put a
- put (TypeSynonymEntity a) = putWord8 1 >> put a
- put (EnumEntity a b) = putWord8 2 >> put a >> put b
- put AdditionalTypeEntity = putWord8 3
- put (SelectorEntity a) = putWord8 4 >> put a
- put (ProtocolEntity a b) = putWord8 5 >> put a >> put b
- put MethodEntity = putWord8 6
- put ProtocolAdoptionEntity = putWord8 7
- put (ExternVarEntity a) = putWord8 8 >> put a
- put (ExternFunEntity a) = putWord8 9 >> put a
- put (ReexportEntity a) = putWord8 10 >> put a
- put (AdditionalCodeEntity a b c d) = putWord8 11 >> put a >> put b >>
put c >> put d
- get = do
- tag_ <- getWord8
- case tag_ of
- 0 -> get >>= \a -> return (ClassEntity a)
- 1 -> get >>= \a -> return (TypeSynonymEntity a)
- 2 -> get >>= \a -> get >>= \b -> return (EnumEntity a b)
- 3 -> return AdditionalTypeEntity
- 4 -> get >>= \a -> return (SelectorEntity a)
- 5 -> get >>= \a -> get >>= \b -> return (ProtocolEntity a b)
- 6 -> return MethodEntity
- 7 -> return ProtocolAdoptionEntity
- 8 -> get >>= \a -> return (ExternVarEntity a)
- 9 -> get >>= \a -> return (ExternFunEntity a)
- 10 -> get >>= \a -> return (ReexportEntity a)
- 11 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return
(AdditionalCodeEntity a b c d)
- _ -> fail "no parse"
-
-instance Binary Entities.Name where
- put (CName a) = putWord8 0 >> put a
- put (ProtocolName a) = putWord8 1 >> put a
- put (SelectorName a) = putWord8 2 >> put a
- put (ProtocolAdoptionName a b) = putWord8 3 >> put a >> put b
- put (SelectorInstanceName a b c) = putWord8 4 >> put a >> put b >> put c
- put Anonymous = putWord8 5
- get = do
- tag_ <- getWord8
- case tag_ of
- 0 -> get >>= \a -> return (CName a)
- 1 -> get >>= \a -> return (ProtocolName a)
- 2 -> get >>= \a -> return (SelectorName a)
- 3 -> get >>= \a -> get >>= \b -> return (ProtocolAdoptionName a b)
- 4 -> get >>= \a -> get >>= \b -> get >>= \c -> return
(SelectorInstanceName a b c)
- 5 -> return Anonymous
- _ -> fail "no parse"
-
-instance Binary Entities.Entity where
- put (Entity a b c d e) = put a >> put b >> put c >> put d >> put e
- get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e
-> return (Entity a b c d e)
-
-instance Binary Entities.EntityPile where
- put (EntityPile a b c) = put a >> put b >> put c
- get = get >>= \a -> get >>= \b -> get >>= \c -> return (EntityPile a b c)
-
-instance Binary CTypeToHaskell.SelectorKind where
- put PlainSelector = putWord8 0
- put CovariantSelector = putWord8 1
- put CovariantInstanceSelector = putWord8 2
- put AllocSelector = putWord8 3
- put InitSelector = putWord8 4
- get = do
- tag_ <- getWord8
- case tag_ of
- 0 -> return PlainSelector
- 1 -> return CovariantSelector
- 2 -> return CovariantInstanceSelector
- 3 -> return AllocSelector
- 4 -> return InitSelector
- _ -> fail "no parse"
+-- list of types that are handled by their real Binary instance
+-- instead of the generic code below
+specialTypes = [
+ BinaryType (undefined :: ByteString),
+ BinaryType (undefined :: String),
+ BinaryType (undefined :: Int)
+ ]
+
+gput :: Data a => a -> Put
+gput thing
+ = fromMaybe gput0 $ msum $ map gput1 specialTypes
+ where
+ gput0 = case constrRep (toConstr thing) of
+ IntConstr i -> put i
+ FloatConstr f -> put f
+ StringConstr s -> put s
+ AlgConstr i -> do
+ putWord8 (fromIntegral i)
+ gmapM (\x -> gput x >> return x) thing
+ return ()
+
+ gput1 (BinaryType t) = fmap put $ cast thing `asTypeOf` Just t
+
+gget :: Data a => Get a
+gget
+ = mfix gget' where
+
+ gget' result =
+ fromMaybe gget0 $ msum $ map gget1 specialTypes
+ where
+ dataType = dataTypeOf result
+ resultType = typeOf result
+
+ gget0 = do
+ constr <- case dataTypeRep dataType of
+ IntRep -> do
+ i <- get
+ return $ mkIntConstr dataType i
+ FloatRep -> do
+ f <- get
+ return $ mkFloatConstr dataType f
+ StringRep -> do
+ s <- get
+ return $ mkStringConstr dataType s
+ AlgRep constrs -> do
+ i <- getWord8
+ return (constrs !! (fromIntegral i - 1))
+ fromConstrM gget constr
+
+ gget1 :: Data a => BinaryType -> Maybe (Get a)
+ gget1 (BinaryType t)
+ | typeOf t == resultType
+ = Just (get >>= \x -> return $ fromJust $ cast $ x
`asTypeOf` t)
+ | otherwise = Nothing
+
+
+-- use gget and ggput to declare Binary instances for the types we need
+
+instance Binary Entity where
+ put = gput
+ get = gget
+instance Binary EntityID where
+ put = gput
+ get = gget
|
|
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
|
|
From: <cod...@go...> - 2008-10-01 21:53:14
|
Author: wol...@gm...
Date: Wed Oct 1 14:49:06 2008
New Revision: 326
Modified:
trunk/hoc/InterfaceGenerator2/BuildEntities.hs
Log:
Generate getter and setter selectors for ObjC 2.0 @properties.
Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs Wed Oct 1 14:49:06 2008
@@ -15,7 +15,7 @@
import HOC.SelectorNameMangling
import Control.Monad.State
-import Data.Char ( isUpper, isLower, isAlphaNum )
+import Data.Char ( isUpper, isLower, isAlphaNum, toUpper )
import Data.List ( groupBy, isPrefixOf )
import Data.Maybe ( fromMaybe, catMaybes )
import System.Directory ( doesFileExist )
@@ -89,7 +89,7 @@
makeSelectorEntity factory modName _clsID clsName sel
= if hidden
- then return Nothing
+ then return []
else do
entity <- newEntity $ Entity {
eName = SelectorName $ BS.pack name,
@@ -98,7 +98,7 @@
eInfo = SelectorEntity (UnconvertedType (kind,
sel')),
eModule = LocalModule modName
}
- return $ Just (entity, factory)
+ return $ [(entity, factory)]
where
selectorOptions = getSelectorOptions bindingScript clsName
@@ -134,14 +134,24 @@
makeEntitiesForSelectorListItem modName clsID clsName (ClassMethod
sel)
= makeSelectorEntity True modName clsID clsName sel
makeEntitiesForSelectorListItem modName _clsID _clsName (LocalDecl
decl)
- = makeEntity modName decl >> return Nothing
- makeEntitiesForSelectorListItem _modName _clsID _clsName
(PropertyDecl _)
- = return Nothing
+ = makeEntity modName decl >> return []
+ makeEntitiesForSelectorListItem modName clsID clsName
(PropertyDecl typ name attr)
+ = do
+ getter <- makeSelectorEntity False modName clsID clsName
getterSel
+ setter <- makeSelectorEntity False modName clsID clsName
setterSel
+ return (getter ++ setter)
+ where
+ getterName = head $ [ n | Getter n <- attr ] ++ [ name ]
+ setterName = head $ [ n | Setter n <- attr ] ++
+ [ "set" ++ toUpper (head name) : tail
name ++ ":" ]
+ getterSel = Selector getterName typ [] False
+ setterSel = Selector setterName
+ (CTSimple "void") [typ] False
makeEntitiesForSelectorListItem _modName _clsID _clsName (Required
_)
- = return Nothing
+ = return []
makeSelectorEntities modName clsID clsName items
- = fmap catMaybes $
+ = fmap concat $
mapM (makeEntitiesForSelectorListItem modName clsID clsName)
items
makeSelectorInstance modName classEntity (selectorEntity, factory)
|
|
From: <cod...@go...> - 2008-09-30 22:44:30
|
Author: wol...@gm...
Date: Tue Sep 30 15:43:17 2008
New Revision: 323
Modified:
trunk/hoc/Bindings/just-generate.sh
trunk/hoc/Bindings/make-bindings-macos.sh
Log:
more cleanup in binding generator scripts
Modified: trunk/hoc/Bindings/just-generate.sh
==============================================================================
--- trunk/hoc/Bindings/just-generate.sh (original)
+++ trunk/hoc/Bindings/just-generate.sh Tue Sep 30 15:43:17 2008
@@ -1,24 +1,15 @@
-function build()
-{
- true
-}
-
ARGUMENTS=$*
+OPTS=-q
-IFGEN=hoc-ifgen #"../../InterfaceGenerator2/hoc-ifgen"
+IFGEN=hoc-ifgen
+set -e
mkdir -p Generated
cd Generated
-OPTS=-q
$IFGEN Foundation -f -b ../binding-script.txt -a ../AdditionalCode/ $OPTS
-build Foundation
$IFGEN QuartzCore -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation $OPTS
-build QuartzCore
$IFGEN AppKit -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation -d QuartzCore $OPTS
-build AppKit
$IFGEN CoreData -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation \
-d AppKit -d QuartzCore $OPTS # fake dependencies
-build CoreData
$IFGEN Cocoa -u -d Foundation -d QuartzCore -d AppKit -d CoreData $OPTS
-build Cocoa
Modified: trunk/hoc/Bindings/make-bindings-macos.sh
==============================================================================
--- trunk/hoc/Bindings/make-bindings-macos.sh (original)
+++ trunk/hoc/Bindings/make-bindings-macos.sh Tue Sep 30 15:43:17 2008
@@ -10,19 +10,20 @@
ARGUMENTS=$*
OPTS=
+IFGEN=hoc-ifgen
+
set -e
mkdir -p Generated
cd Generated
-
-hoc-ifgen Foundation -f -b ../binding-script.txt -a ../AdditionalCode/
$OPTS
-build HOC-Foundation
-hoc-ifgen QuartzCore -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation $OPTS
-build HOC-QuartzCore
-hoc-ifgen AppKit -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation -d QuartzCore $OPTS
-build HOC-AppKit
-hoc-ifgen CoreData -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation \
- -d AppKit -d QuartzCore $OPTS # fake dependencies
-build HOC-CoreData
-hoc-ifgen Cocoa -u -d Foundation -d QuartzCore -d AppKit -d CoreData $OPTS
-build HOC-Cocoa
+$IFGEN Foundation -f -b ../binding-script.txt -a ../AdditionalCode/ $OPTS
+build Foundation
+$IFGEN QuartzCore -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation $OPTS
+build QuartzCore
+$IFGEN AppKit -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation -d QuartzCore $OPTS
+build AppKit
+$IFGEN CoreData -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation \
+ -d AppKit -d QuartzCore $OPTS # fake dependencies
+build CoreData
+$IFGEN Cocoa -u -d Foundation -d QuartzCore -d AppKit -d CoreData $OPTS
+build Cocoa
|
|
From: <cod...@go...> - 2008-09-29 20:37:48
|
Author: wol...@gm...
Date: Mon Sep 29 13:37:28 2008
New Revision: 322
Removed:
trunk/hoc/Bindings/AdditionalCode/Foundation/NSObjCRuntime.hs
Modified:
trunk/hoc/Bindings/binding-script.txt
trunk/hoc/Bindings/just-generate.sh
trunk/hoc/Bindings/make-bindings-macos.sh
Log:
cleanup in binding-script and related things
Modified: trunk/hoc/Bindings/binding-script.txt
==============================================================================
--- trunk/hoc/Bindings/binding-script.txt (original)
+++ trunk/hoc/Bindings/binding-script.txt Mon Sep 29 13:37:28 2008
@@ -1,7 +1,7 @@
-hidePrelude init error minimum maximum null concat words print length
compare;
rename data data';
rename type type';
rename class class';
+-- hidePrelude init error minimum maximum null concat words print length
compare;
covariant stringWithCString stringWithCStringLength;
covariant stringWithContentsOfFile stringWithContentsOfURL;
@@ -26,21 +26,26 @@
rename drawKnob: drawKnob_;
rename titleWidth: titleWidth_;
-class NSDistributedNotificationCenter {
- hide addObserver:selector:name:object: postNotificationName:object:
- postNotificationName:object:userInfo:
removeObserver:name:object: ;
-}
-
+ -- resolve type conflicts between NSUserDefaults & NSDictionary
+ -- NSUserDefaults use NSString keys
class NSUserDefaults {
- (id) objectForKey: (id) key;
- (void) removeObjectForKey: (id) key;
- (void) setObject: (id) object forKey: (id) key;
}
+ -- NSStatusItem has a CGFloat length
class NSStatusItem {
hide setLength: length;
}
+
+class NSDistributedNotificationCenter {
+ hide addObserver:selector:name:object: postNotificationName:object:
+ postNotificationName:object:userInfo:
removeObserver:name:object: ;
+}
+
+
class NSToolbar {
- (id) initWithIdentifier: (id) ident;
}
@@ -57,23 +62,20 @@
- (void) setContentView: (NSView*) view;
}
-
type NSPoint Foundation.NSGeometry;
type NSSize Foundation.NSGeometry;
type NSRect Foundation.NSGeometry;
type NSRange Foundation.NSRange;
-type NSInteger Foundation.NSObjCRuntime;
-type NSUInteger Foundation.NSObjCRuntime;
-
-- GNUstep specifics:
+{-
rename rawMimeData: rawMimeData_;
rename setContent:type: setContentAndType;
rename setContent:type:name: setContentAndTypeAndName;
rename removePort:forName: removePort_forName;
-hide performSelector:withObject:afterDelay:;
-hide performSelector:withObject:afterDelay:inModes:;
+-- hide performSelector:withObject:afterDelay:;
+-- hide performSelector:withObject:afterDelay:inModes:;
class GSXMLNamespace {
rename next nextNamespace;
@@ -99,3 +101,4 @@
hideEnums _NSGNUstepStringEncoding NSGNUstepStringEncoding;
+-}
Modified: trunk/hoc/Bindings/just-generate.sh
==============================================================================
--- trunk/hoc/Bindings/just-generate.sh (original)
+++ trunk/hoc/Bindings/just-generate.sh Mon Sep 29 13:37:28 2008
@@ -5,19 +5,20 @@
ARGUMENTS=$*
-IFGEN="../../InterfaceGenerator2/hoc-ifgen"
+IFGEN=hoc-ifgen #"../../InterfaceGenerator2/hoc-ifgen"
mkdir -p Generated
cd Generated
-$IFGEN Foundation -f -b ../binding-script.txt -a ../AdditionalCode/
+OPTS=-q
+$IFGEN Foundation -f -b ../binding-script.txt -a ../AdditionalCode/ $OPTS
build Foundation
-$IFGEN QuartzCore -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation
+$IFGEN QuartzCore -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation $OPTS
build QuartzCore
-$IFGEN AppKit -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation -d QuartzCore
+$IFGEN AppKit -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation -d QuartzCore $OPTS
build AppKit
$IFGEN CoreData -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation \
- -d AppKit -d QuartzCore # fake dependencies
+ -d AppKit -d QuartzCore $OPTS # fake dependencies
build CoreData
-$IFGEN Cocoa -u -d Foundation -d QuartzCore -d AppKit -d CoreData
+$IFGEN Cocoa -u -d Foundation -d QuartzCore -d AppKit -d CoreData $OPTS
build Cocoa
Modified: trunk/hoc/Bindings/make-bindings-macos.sh
==============================================================================
--- trunk/hoc/Bindings/make-bindings-macos.sh (original)
+++ trunk/hoc/Bindings/make-bindings-macos.sh Mon Sep 29 13:37:28 2008
@@ -8,19 +8,21 @@
}
ARGUMENTS=$*
+OPTS=
set -e
mkdir -p Generated
cd Generated
-hoc-ifgen Foundation -f -b ../binding-script.txt -a ../AdditionalCode/
+
+hoc-ifgen Foundation -f -b ../binding-script.txt -a ../AdditionalCode/
$OPTS
build HOC-Foundation
-hoc-ifgen QuartzCore -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation
+hoc-ifgen QuartzCore -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation $OPTS
build HOC-QuartzCore
-hoc-ifgen AppKit -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation -d QuartzCore
+hoc-ifgen AppKit -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation -d QuartzCore $OPTS
build HOC-AppKit
hoc-ifgen CoreData -f -b ../binding-script.txt -a ../AdditionalCode/ -d
Foundation \
- -d AppKit -d QuartzCore # fake dependencies
+ -d AppKit -d QuartzCore $OPTS # fake dependencies
build HOC-CoreData
-hoc-ifgen Cocoa -u -d Foundation -d QuartzCore -d AppKit -d CoreData
+hoc-ifgen Cocoa -u -d Foundation -d QuartzCore -d AppKit -d CoreData $OPTS
build HOC-Cocoa
|
|
From: <cod...@go...> - 2008-09-29 20:18:43
|
Author: wol...@gm...
Date: Mon Sep 29 13:18:20 2008
New Revision: 321
Modified:
trunk/hoc/InterfaceGenerator2/BindingScript.hs
trunk/hoc/InterfaceGenerator2/Headers.hs
Log:
Remove some dead code
Modified: trunk/hoc/InterfaceGenerator2/BindingScript.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BindingScript.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BindingScript.hs Mon Sep 29 13:18:20 2008
@@ -197,7 +197,7 @@
readBindingScript fn = do
f <- readFile fn
- let (either, messages) = runMessages (runParserT bindingScript () fn f)
+ 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 Mon Sep 29 13:18:20 2008
@@ -73,20 +73,6 @@
where
nHeaders = length headers
-orderModules :: [HeaderInfo] -> [HeaderInfo]
-
-orderModules [] = []
-orderModules mods = if null ok
- then (head notOK) : orderModules (tail notOK)
- else ok ++ orderModules notOK
- where
- (notOK, ok) = partition (\(HeaderInfo name imports decls) ->
- any (`elem` names) imports) mods
- names = map (\(HeaderInfo name imports decls) -> name) mods
- -- names | any ("Foundation." `isPrefixOf`) names'
= "Foundation.Foundation" : names'
- -- | otherwise = names'
-
-
haskellizeModuleName = firstUpper . concatMap translateChar
where firstUpper [] = []
firstUpper (x:xs) = toUpper x : upperAfterDot xs
|
|
From: <cod...@go...> - 2008-09-29 20:12:40
|
Author: wol...@gm...
Date: Mon Sep 29 13:12:09 2008
New Revision: 320
Added:
trunk/hoc/Tools/HOC-Tools.cabal
trunk/hoc/Tools/Setup.hs
Modified:
trunk/hoc/Tools/HOCWrap.hs
Log:
Add cabal file for HOCWrap
Added: trunk/hoc/Tools/HOC-Tools.cabal
==============================================================================
--- (empty file)
+++ trunk/hoc/Tools/HOC-Tools.cabal Mon Sep 29 13:12:09 2008
@@ -0,0 +1,10 @@
+name: HOC-Tools
+version: 1.0
+build-type: Simple
+
+-- containers, bytestring, mtl, pretty, parsec, fgl,
+ -- template-haskell, binary >= 0.2, old-time, directory
+
+executable: hoc-wrap
+main-is: HOCWrap.hs
+build-depends: base, unix, HOC, HOC-Foundation, process, filepath
Modified: trunk/hoc/Tools/HOCWrap.hs
==============================================================================
--- trunk/hoc/Tools/HOCWrap.hs (original)
+++ trunk/hoc/Tools/HOCWrap.hs Mon Sep 29 13:12:09 2008
@@ -1,18 +1,21 @@
module Main where
import Prelude hiding ( init )
+import qualified Prelude
import Control.Exception ( handle, throw, handleJust, userErrors )
import Control.Monad ( when )
import Data.List ( isSuffixOf )
import System.Console.GetOpt
import System.Environment ( getArgs, getProgName )
-import System.IO ( hPutStrLn, hClose )
+import System.IO ( hPutStrLn, hClose, hGetContents )
import System.IO.Unsafe ( unsafePerformIO )
import System.Exit ( exitWith, ExitCode(..) )
import System.Posix ( createPipe, dupTo, stdInput, closeFd,
fdToHandle, forkProcess, executeFile,
getProcessStatus )
+import System.Process ( runInteractiveCommand, waitForProcess )
+import System.FilePath ( (</>), takeFileName, takeBaseName )
import HOC
import Foundation.NSFileManager
@@ -20,6 +23,16 @@
import Foundation.NSDictionary
import Foundation.NSObject
+backquote :: String -> IO String
+
+backquote cmd = do
+ (inp,out,err,pid) <- runInteractiveCommand cmd
+ hClose inp
+ text <- hGetContents out
+ waitForProcess pid
+ hClose err
+ return text
+
data Option = OutputApp String
| Contents String
| Interpret
@@ -78,7 +91,7 @@
appName def = forceDotApp $
head $ [ s | OutputApp s <- opts ]
- ++ [def]
+ ++ [takeBaseName def]
forceDotApp x | ".app" `isSuffixOf` x = x
| otherwise = x ++ ".app"
@@ -147,9 +160,8 @@
let executableInApp = take (length appName - length ".app") appName
-
- let ghcLib = "/usr/local/lib/ghc-6.4"
- ghcExecutable = ghcLib ++ "/ghc-6.4"
+ ghcLib <- fmap Prelude.init $ backquote "ghc --print-libdir"
+ let ghcExecutable = ghcLib </> takeFileName ghcLib
wrapApp' True False ghcExecutable appName contents
Added: trunk/hoc/Tools/Setup.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/Tools/Setup.hs Mon Sep 29 13:12:09 2008
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
|
|
From: <cod...@go...> - 2008-09-28 23:01:21
|
Author: wol...@gm...
Date: Sun Sep 28 16:00:58 2008
New Revision: 319
Modified:
trunk/hoc/InterfaceGenerator2/Headers.hs
trunk/hoc/InterfaceGenerator2/Parser.hs
Log:
Some more cleanup
Modified: trunk/hoc/InterfaceGenerator2/Headers.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Headers.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Headers.hs Sun Sep 28 16:00:58 2008
@@ -26,20 +26,6 @@
data HeaderInfo = HeaderInfo ModuleName [ModuleName] [Declaration]
deriving(Show)
-stripPreprocessor = unlines . stripPP . lines
- where
- stripPP (('#':'e':'l':'s':'e':_) : xs) = "" : dropElseHack xs
- stripPP (x@('#':_) : xs) = dropPreprocessorLine x xs
- stripPP (x : xs) = x : stripPP xs
- stripPP [] = []
- dropPreprocessorLine x xs
- | last x == '\\' = "" : dropPreprocessorLine (head xs) (tail
xs)
- | otherwise = "" : stripPP xs
-
- dropElseHack (('#':'e':'n':'d':'i':'f':_) : xs) = "" : stripPP xs
- dropElseHack (x : xs) = "" : dropElseHack xs
- dropElseHack [] = []
-
findImports = mapMaybe checkImport . lines
where
checkImport line
@@ -70,7 +56,7 @@
contents <- readFile $ headerPathName
evaluate (length contents)
let imports = findImports contents
- preprocessed = preprocess headerFileName {-
stripPreprocessor -} contents
+ preprocessed = preprocess headerFileName contents
when dumpPreprocessed $ writeFile ("preprocessed-" ++
headerFileName) $ preprocessed
let (parseResult, parseMessages) = runMessages (runParserT
header () headerFileName preprocessed)
Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs Sun Sep 28 16:00:58 2008
@@ -22,6 +22,9 @@
type Parser a = ParsecT String () Messages a
+-- type Parser a = forall b. ParsecT String b Messages a
+
+
objcDef = LanguageDef
{ commentStart = "/*"
, commentEnd = "*/"
@@ -66,144 +69,126 @@
uninterestingThing = skipMany1 (satisfy (\x -> x /= '@' && x /= ';')) >>
return Nothing
interestingThing =
- class_decl
+ ignoredToplevelThing
+ <|> class_decl
<|> (try protocol_decl)
<|> 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 [])
-empty_decl = semi objc >> return []
+ignoredToplevelThing
+ = (foldl1 (<|>) . map (reserved objc))
+ ["CA_EXTERN_C_BEGIN", "CA_EXTERN_C_END",
+ "CF_EXTERN_C_BEGIN", "CF_EXTERN_C_END"]
+ >> return []
+--
-class_decl = do
- reserved objc "@class"
- classes <- commaSep1 objc (identifier objc)
- semi objc
- return [ForwardClass classes]
+skipParens = parens objc (skipMany (
+ (satisfy (\x -> x /= '(' && x /= ')') >> return ())
+ <|> skipParens
+ ))
-protocol_decl = do
- reserved objc "@protocol"
- protos <- commaSep1 objc (identifier objc)
- semi objc
- return [ForwardProtocol protos]
+skipBlockContents = (skipMany (
+ (satisfy (\x -> x /= '{' && x /= '}') >> return ())
+ <|> skipBlock
+ ))
+skipBlock = braces objc skipBlockContents
-interface_decl = do
- proto <- (reserved objc "@interface" >> return False)
- <|> (reserved objc "@protocol" >> return True)
- class_name <- identifier objc
- what <- if proto
- then do
- protos <- protocol_spec
- return $ Protocol class_name protos
- else (do
- cat_name <- category_spec
- protos <- protocol_spec
- return $ Category class_name cat_name protos
- ) <|> (do
- super <- superclass_spec
- protos <- protocol_spec
- return $ Interface class_name super protos
- )
- instance_variables
- selectors <- fmap concat $ many selectorListItem
- reserved objc "@end"
- return [SelectorList what selectors]
-
-category_spec = parens objc (identifier objc)
-
-superclass_spec = (do
- colon objc
- superclass <- identifier objc
- return $ Just superclass
- ) <|> return Nothing
-
-protocol_spec =
- angles objc (commaSep1 objc (identifier objc))
- <|> return []
-
-instance_variables = skipBlock <|> return ()
+skipEnumValue = skipMany1 (satisfy (\x -> x /= '}' && x /= ','))
-selectorListItem
- = fmap singleton selector
- <|> fmap (map LocalDecl) type_declaration
- <|> fmap (map LocalDecl) extern_decl
- <|> property_declaration
- <|> fmap singleton requiredOrOptional
- <|> (semi objc >> return [])
+-- Plain C
-requiredOrOptional
- = (reserved objc "@required" >> return (Required True))
- <|> (reserved objc "@optional" >> return (Required False))
+empty_decl :: Parser [a]
+empty_decl = semi objc >> return []
-selector = do
- classOrInstanceMethod <-
- (symbol objc "-" >> return InstanceMethod)
- <|> (symbol objc "+" >> return ClassMethod)
- -- str <- many (satisfy (\c -> c /= ';' && c /= '@'))
- rettype <- type_spec
- (name,types,vararg) <- (
+
+const_int_expr :: Map.Map String Integer -> Parser Integer
+const_int_expr env = expr
+ where
+ expr = buildExpressionParser optable basic
+
+ basic = suffixedInteger
+ <|> multiCharConstant
+ <|> definedConstant
+ <|> parens objc expr
+
+ optable = [ [Infix (op "<<" (cast2nd shiftL)) AssocLeft],
+ [Infix (op "|" (.|.)) AssocLeft] ]
+ where
+ op str f = reservedOp objc str >> return f
+ cast2nd f x y = f x (fromIntegral y)
+
+ suffixedInteger =
do
- manythings <- many1 (try $ do
- namePart <- identifier objc <|> return ""
- colon objc
- argType <- type_spec
- argName <- identifier objc
- return (namePart, argType)
- )
- vararg <- (symbol objc "," >> symbol objc "..." >> return
True) <|> return False
- let (nameParts,types) = unzip manythings
- return (concat $ map (++":") nameParts , types, vararg)
- ) <|> (
+ val <- integer objc
+ optional (reserved objc "U" <|> reserved objc "L"
+ <|> reserved objc "UL") -- ### TODO: no space
allowed before 'U'
+ return val
+
+ multiCharConstant =
+ lexeme objc (between (char '\'') (char '\'') multiChars)
+ where
+ multiChars = do
+ chars <- many1 (satisfy (/= '\''))
+ return $ sum $ zipWith (*)
+ (map (fromIntegral.ord) $ reverse chars)
+ (iterate (*256) 1)
+
+ definedConstant =
do
name <- identifier objc
- return (name,[],False)
- )
- availability
- semi objc
- return (classOrInstanceMethod $ Selector name rettype types vararg)
-
-property_declaration
- = do
- reserved objc "@property"
- properties <- option [] (parens objc (commaSep objc $
property_attribute))
- basetype <- type_no_pointers
- things <- commaSep objc id_declarator
- availability
- semi objc
- 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)
+ Map.lookup name env <|> (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])"
+ctype = do
+ simple <- simple_type
+ (_, f) <- declarator True (return ())
+ return (f simple)
---type_spec = try (parens objc ctype) <|> (skipParens >> return CTUnknown)
<|> return (CTIDType [])
-type_spec = parens objc ctype <|> return (CTIDType [])
+-- A simple_type is a C type without any pointers, arrays or functions.
+-- (but including struct, enum and union declarations).
+-- If you declare multiple variables in one C declaration, the simple_type
+-- is what they have in common.
+-- Examples include "int", "const char", "char const", "struct {int *x;}",
+-- but NOT "const char*".
-type_no_pointers = do -- "const char" in "const char *foo[32]"
+simple_type = do -- "const char" in "const char *foo[32]"
many ignored_type_qualifier -- ignore
- t <- simple_type
+ t <- id_type
+ <|> enum_type
+ <|> struct_type
+ <|> try builtin_type
+ <|> do n <- identifier objc
+ protos <- protocol_spec -- TOOD: use these protocols
+ return $ CTSimple n
many ignored_type_qualifier
return t
+ignored_type_qualifier =
+ reserved objc "const"
+ <|> reserved objc "volatile"
+ <|> reserved objc "in"
+ <|> reserved objc "out"
+ <|> reserved objc "inout"
+ <|> reserved objc "bycopy"
+ <|> reserved objc "byref"
+ <|> reserved objc "oneway"
+ <|> reserved objc "__strong"
+
+-- An id_declarator is an identifier surrounded by things like "*", "[]"
and
+-- function arguments.
+-- In a declaration of a single C variable or function, everything except
the
+-- simple_type is part of the id_declarator.
+-- In the declaration "const char *x[32]", "*x[32]" is the id_declarator.
+-- The parser returns the identifier and a function that transforms the
+-- simple_type ("const char" in the example) to the type of the identifier
+-- ("const char * [32]" in the example).
+
+id_declarator :: Parser (String, CType -> CType)
id_declarator = declarator False (identifier objc)
declarator :: Bool -> Parser a -> Parser (a, CType -> CType)
@@ -243,20 +228,11 @@
argument =
(symbol objc "..." >> return Nothing)
<|> do
- t <- type_no_pointers
+ t <- simple_type
(_, tf) <- declarator True (optional $ identifier
objc)
return $ Just $ tf t
-
-ctype = do
- simple <- type_no_pointers
- (_, f) <- declarator True (return ())
- return (f simple)
-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))
@@ -283,39 +259,6 @@
return $ CTIDType protos
-multiCharConstant =
- lexeme objc (between (char '\'') (char '\'') multiChars)
- where
- multiChars = do
- chars <- many1 (satisfy (/= '\''))
- return $ sum $ zipWith (*)
- (map (fromIntegral.ord) $ reverse chars)
- (iterate (*256) 1)
-
-
-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
- expr = buildExpressionParser optable basic
- basic = suffixedInteger
- <|> multiCharConstant
- <|> (do name <- identifier objc
--- Map.lookup name env <?> (name ++ " undefined"))
- Map.lookup name env <|> (parseWarning (name ++ "
undefined") >> fail ""))
- <|> 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
enum_type =
do
@@ -355,7 +298,7 @@
struct_union_body = try (many member)
<|> (skipBlockContents >> parseWarning "problem parsing
struct" >> return [])
member = do
- typ <- type_no_pointers
+ typ <- simple_type
things <- commaSep objc $ do
(name, typeModifiers) <- id_declarator
bitfield <- option Nothing
@@ -364,25 +307,11 @@
availability
semi objc
return [ (modifier typ, name) | (name, modifier) <- things ]
-
-type_operator =
- (symbol objc "*" >> return CTPointer)
- <|> (ignored_type_qualifier >> return id)
-ignored_type_qualifier =
- reserved objc "const"
- <|> reserved objc "volatile"
- <|> reserved objc "in"
- <|> reserved objc "out"
- <|> reserved objc "inout"
- <|> reserved objc "bycopy"
- <|> reserved objc "byref"
- <|> reserved objc "oneway"
- <|> reserved objc "__strong"
typedef = do
reserved objc "typedef"
- baseType <- type_no_pointers
+ baseType <- simple_type
newTypes <- commaSep objc id_declarator
availability
@@ -401,7 +330,7 @@
extern_decl =
do
optional extern_keyword
- t <- type_no_pointers
+ t <- simple_type
vars <- commaSep objc (one_var t)
availability
semi objc
@@ -414,17 +343,7 @@
-> ExternFun (Selector n retval args varargs)
otherType
-> ExternVar otherType n
-
-availability :: Parser ()
-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".
@@ -432,25 +351,147 @@
<|> reserved objc "GS_EXPORT"
<|> reserved objc "CA_EXTERN"
<|> reserved objc "CF_EXPORT"
+ <|> reserved objc "COREDATA_EXTERN"
-skipParens = parens objc (skipMany (
- (satisfy (\x -> x /= '(' && x /= ')') >> return ())
- <|> skipParens
- ))
-
-skipBlockContents = (skipMany (
- (satisfy (\x -> x /= '{' && x /= '}') >> return ())
- <|> skipBlock
- ))
-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
+ t <- simple_type
(n, tf) <- id_declarator
skipBlock
return []
+
+
+-- Ignore __attribute__((...)) and Apple's countless different
availability macros,
+-- which all expand to some __attribute__. My favourite example is
+-- "AVAILABLE_MAC_OS_X_VERSION_10_1_AND_LATER_BUT_DEPRECATED_IN_MAC_OS_X_VERSION_10_3"
+
+availability :: Parser ()
+availability = fmap (const ()) $ many $
+ 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_"])
+
+
+-- Objective C
+
+class_decl = do
+ reserved objc "@class"
+ classes <- commaSep1 objc (identifier objc)
+ semi objc
+ return [ForwardClass classes]
+
+protocol_decl = do
+ reserved objc "@protocol"
+ protos <- commaSep1 objc (identifier objc)
+ semi objc
+ return [ForwardProtocol protos]
+
+interface_decl = do
+ proto <- (reserved objc "@interface" >> return False)
+ <|> (reserved objc "@protocol" >> return True)
+ class_name <- identifier objc
+ what <- if proto
+ then do
+ protos <- protocol_spec
+ return $ Protocol class_name protos
+ else (do
+ cat_name <- category_spec
+ protos <- protocol_spec
+ return $ Category class_name cat_name protos
+ ) <|> (do
+ super <- superclass_spec
+ protos <- protocol_spec
+ return $ Interface class_name super protos
+ )
+ instance_variables
+ selectors <- fmap concat $ many selectorListItem
+ reserved objc "@end"
+ return [SelectorList what selectors]
+ where
+ category_spec = parens objc (identifier objc)
+
+ superclass_spec = (do
+ colon objc
+ superclass <- identifier objc
+ return $ Just superclass
+ ) <|> return Nothing
+
+protocol_spec =
+ angles objc (commaSep1 objc (identifier objc))
+ <|> return []
+
+instance_variables = skipBlock <|> return ()
+
+selectorListItem
+ = 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))
+ <|> (reserved objc "@optional" >> return (Required False))
+
+selector = do
+ classOrInstanceMethod <-
+ (symbol objc "-" >> return InstanceMethod)
+ <|> (symbol objc "+" >> return ClassMethod)
+ -- str <- many (satisfy (\c -> c /= ';' && c /= '@'))
+ rettype <- option (CTIDType []) (parens objc ctype)
+ (name,types,vararg) <- (
+ do
+ manythings <- many1 (try $ do
+ namePart <- identifier objc <|> return ""
+ colon objc
+ argType <- option (CTIDType []) (parens objc ctype)
+ argName <- identifier objc
+ return (namePart, argType)
+ )
+ vararg <- (symbol objc "," >> symbol objc "..." >> return
True) <|> return False
+ let (nameParts,types) = unzip manythings
+ return (concat $ map (++":") nameParts , types, vararg)
+ ) <|> (
+ do
+ name <- identifier objc
+ return (name,[],False)
+ )
+ availability
+ semi objc
+ return (classOrInstanceMethod $ Selector name rettype types vararg)
+
+property_declaration
+ = do
+ reserved objc "@property"
+ properties <- option [] (parens objc (commaSep objc $
property_attribute))
+ basetype <- simple_type
+ things <- commaSep objc id_declarator
+ availability
+ semi objc
+ return $ map (\ (name, typeModifiers) -> PropertyDecl $
+ Property (typeModifiers $ basetype)
+ name properties ) things
+ where
+ 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)
+
|
