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-09-28 21:03:05
|
Author: wol...@gm...
Date: Sun Sep 28 14:02:46 2008
New Revision: 318
Modified:
trunk/hoc/HOC.cabal
Log:
Clean up package dependencies
Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal (original)
+++ trunk/hoc/HOC.cabal Sun Sep 28 14:02:46 2008
@@ -11,8 +11,8 @@
(requires binary package)
Library
- build-depends: base, containers, bytestring, mtl, pretty, parsec, fgl,
- template-haskell, old-time, directory, unix
+ build-depends: base, template-haskell, unix
+
exposed-modules:
HOC,
HOC.NameCaseChange,
@@ -67,7 +67,8 @@
main-is: Main.hs
hs-source-dirs: HOC, InterfaceGenerator2
- build-depends: filepath
+ build-depends: containers, bytestring, mtl, pretty, parsec >= 3.0, fgl,
+ old-time, directory, filepath
if flag(BinaryInterfaces)
build-depends: binary >= 0.2
cpp-options: -DBINARY_INTERFACES
|
|
From: <cod...@go...> - 2008-09-28 20:59:04
|
Author: wol...@gm...
Date: Sun Sep 28 13:58:13 2008
New Revision: 317
Modified:
trunk/hoc/InterfaceGenerator2/BindingScript.hs
trunk/hoc/InterfaceGenerator2/Headers.hs
trunk/hoc/InterfaceGenerator2/Messages.hs
trunk/hoc/InterfaceGenerator2/Parser.hs
trunk/hoc/InterfaceGenerator2/Preprocessor.hs
Log:
Further parser improvements:
* some bugfixes
* recognise & skip inline functions
* require parsec 3.0
* output warning messages for unhandled enum values
Modified: trunk/hoc/InterfaceGenerator2/BindingScript.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BindingScript.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BindingScript.hs Sun Sep 28 13:58:13 2008
@@ -13,6 +13,7 @@
Selector(..)
)
import qualified Parser(selector)
+import Parser(Parser)
import Control.Monad(when)
import qualified Data.Map as Map
@@ -20,9 +21,10 @@
import qualified Data.Set as Set hiding (Set)
import Data.List(intersperse)
-import Text.ParserCombinators.Parsec.Language(haskellStyle)
-import Text.ParserCombinators.Parsec.Token
-import Text.ParserCombinators.Parsec
+import Text.Parsec.Token
+import Text.Parsec
+
+import Messages
data BindingScript = BindingScript {
bsHiddenFromPrelude :: Set String,
@@ -80,10 +82,23 @@
where
top = bsTopLevelOptions bindingScript
-tokenParser :: TokenParser ()
-tokenParser = makeTokenParser $ haskellStyle { identStart = letter <|>
char '_' }
+tokenParser :: GenTokenParser String () Messages
+tokenParser = makeTokenParser $
+ LanguageDef
+ { commentStart = "{-"
+ , commentEnd = "-}"
+ , commentLine = "--"
+ , nestedComments = True
+ , identStart = letter <|> char '_'
+ , identLetter = alphaNum <|> oneOf "_'"
+ , opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , reservedOpNames= []
+ , reservedNames = []
+ , caseSensitive = True
+ }
-selector, qualified :: TokenParser () -> Parser String
+selector, qualified :: GenTokenParser String () Messages -> Parser String
selector tp = lexeme tp $ do
c <- letter <|> char '_'
s <- many (alphaNum <|> oneOf "_:")
@@ -181,7 +196,8 @@
readBindingScript :: String -> IO BindingScript
readBindingScript fn = do
- either <- parseFromFile bindingScript fn
+ f <- readFile fn
+ let (either, messages) = runMessages (runParserT bindingScript () fn f)
case either of
Left err -> error (show err)
Right result -> return result
Modified: trunk/hoc/InterfaceGenerator2/Headers.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Headers.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Headers.hs Sun Sep 28 13:58:13 2008
@@ -14,7 +14,8 @@
import Data.Maybe(mapMaybe)
import System.Directory(getDirectoryContents)
import System.Info(os)
-import Text.ParserCombinators.Parsec(parse)
+import Text.Parsec( runParserT )
+import Messages( runMessages )
import Data.ByteString.Char8(ByteString)
import qualified Data.ByteString.Char8 as BS
import Progress
@@ -71,7 +72,10 @@
let imports = findImports contents
preprocessed = preprocess headerFileName {-
stripPreprocessor -} contents
when dumpPreprocessed $ writeFile ("preprocessed-" ++
headerFileName) $ preprocessed
- result <- case parse header headerFileName preprocessed of
+
+ let (parseResult, parseMessages) = runMessages (runParserT
header () headerFileName preprocessed)
+ mapM_ print parseMessages
+ result <- case parseResult of
Left err -> error $ show err
Right decls -> do
when dumpParsed $ writeFile ("parsed-" ++
headerFileName) $ unlines $ map show decls
Modified: trunk/hoc/InterfaceGenerator2/Messages.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Messages.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Messages.hs Sun Sep 28 13:58:13 2008
@@ -24,7 +24,7 @@
-- mappend a EmptyBag = a more lazyness!
mappend a b = BagOfTwo a b
-type Messages a = Writer (Bag Doc) a
+type Messages = Writer (Bag Doc)
message d = tell (UnitBag d)
runMessages :: Messages a -> (a, [Doc])
Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs Sun Sep 28 13:58:13 2008
@@ -1,47 +1,66 @@
-module Parser( header, selector ) where
+{-# LANGUAGE TypeSynonymInstances #-}
+module Parser( Parser, header, selector ) where
import Data.Maybe(catMaybes, isJust, fromJust)
import Data.Char(ord, isUpper, isDigit)
import Data.Bits(shiftL, (.|.))
import Control.Monad(guard)
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Token
-import Text.ParserCombinators.Parsec.Language(emptyDef)
-import Text.ParserCombinators.Parsec.Expr
+import Text.Parsec
+import Text.Parsec.Token
+import Text.Parsec.Language(emptyDef)
+import Text.Parsec.Expr
import SyntaxTree
import qualified Data.Map as Map
-objcDef = emptyDef
+import Control.Monad.Trans( lift )
+import Messages
+
+import qualified Text.PrettyPrint.HughesPJ as PP
+
+type Parser a = ParsecT String () Messages a
+
+objcDef = LanguageDef
{ commentStart = "/*"
, commentEnd = "*/"
, commentLine = "//"
, nestedComments = False
, identStart = letter <|> char '_'
, identLetter = alphaNum <|> char '_'
+ , opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , reservedOpNames = []
, reservedNames =
["@class","@protocol","@interface","@implementation","@end","@property",
- "const", "volatile", "struct", "union", "enum",
+ "const", "volatile", "struct", "union", "enum", "typedef",
"__attribute__", "__strong",
"@required", "@optional", "@private", "@public" ]
, caseSensitive = True
}
-objc :: TokenParser ()
+objc :: GenTokenParser String () Messages
objc = makeTokenParser objcDef
singleton x = [x]
+parseWarning :: String -> Parser ()
+parseWarning msg
+ = do
+ pos <- getPosition
+ lift (message $ PP.text (show pos ++ ": " ++ msg))
+
header :: Parser [Declaration]
header = do
optional (whiteSpace objc)
- fmap concat $ many $ do
+ things <- fmap concat $ many $ do
-- thing <- try interestingThing <|> uninterestingThing -- lenient
parsing
thing <- interestingThing -- strict parsing
optional (whiteSpace objc)
return thing
+ eof
+ return things
uninterestingThing :: Parser (Maybe Declaration)
uninterestingThing = skipMany1 (satisfy (\x -> x /= '@' && x /= ';')) >>
return Nothing
@@ -52,6 +71,9 @@
<|> interface_decl
<|> empty_decl
<|> type_declaration
+ <|> (reserved objc "CF_EXTERN_C_BEGIN" >> return [])
+ <|> (reserved objc "CF_EXTERN_C_END" >> return [])
+ <|> inline_function
<|> extern_decl
<|> (semi objc >> return [])
@@ -225,12 +247,6 @@
(_, tf) <- declarator True (optional $ identifier
objc)
return $ Just $ tf t
-
-testdecl :: String -> IO ()
-testdecl s = case parse (declarator True (return ()){- (identifier
objc)-}) "" s of
- Right (n, t) -> print $ t (CTSimple "void")
- Left e -> print e
-
ctype = do
simple <- type_no_pointers
(_, f) <- declarator True (return ())
@@ -290,7 +306,8 @@
basic = suffixedInteger
<|> multiCharConstant
<|> (do name <- identifier objc
- Map.lookup name env)
+-- Map.lookup name env <?> (name ++ " undefined"))
+ Map.lookup name env <|> (parseWarning (name ++ "
undefined") >> fail ""))
<|> parens objc expr
optable = [ [Infix shiftLeft AssocLeft],
[Infix bitwiseOr AssocLeft] ]
@@ -322,6 +339,7 @@
>> option [] (enum_body env' (Just
val))
return $ (id, GivenValue val) : xs
Nothing -> do
+ parseWarning $ "Couldn't handle enum value for " ++ id
xs <- option [] $ comma objc
>> option [] (enum_body env Nothing)
return $ (id, TooComplicatedValue "") : xs
@@ -335,7 +353,7 @@
return $ key id body
where
struct_union_body = try (many member)
- <|> (skipBlockContents >> return [])
+ <|> (skipBlockContents >> parseWarning "problem parsing
struct" >> return [])
member = do
typ <- type_no_pointers
things <- commaSep objc $ do
@@ -343,6 +361,7 @@
bitfield <- option Nothing
(symbol objc ":" >> integer objc >>= return . Just)
return (name, typeModifiers)
+ availability
semi objc
return [ (modifier typ, name) | (name, modifier) <- things ]
@@ -381,7 +400,7 @@
extern_decl =
do
- extern_keyword
+ optional extern_keyword
t <- type_no_pointers
vars <- commaSep objc (one_var t)
availability
@@ -395,7 +414,8 @@
-> ExternFun (Selector n retval args varargs)
otherType
-> ExternVar otherType n
-
+
+availability :: Parser ()
availability = optional $
do reserved objc "__attribute__"
parens objc (skipParens)
@@ -410,7 +430,9 @@
<|> reserved objc "FOUNDATION_EXPORT" -- N.B. "Export" vs. "Extern".
<|> reserved objc "APPKIT_EXTERN"
<|> reserved objc "GS_EXPORT"
-
+ <|> reserved objc "CA_EXTERN"
+ <|> reserved objc "CF_EXPORT"
+
skipParens = parens objc (skipMany (
(satisfy (\x -> x /= '(' && x /= ')') >> return ())
<|> skipParens
@@ -423,3 +445,12 @@
skipBlock = braces objc skipBlockContents
skipEnumValue = skipMany1 (satisfy (\x -> x /= '}' && x /= ','))
+
+inline_function =
+ do
+ reserved objc "inline" <|> reserved objc "NS_INLINE"
+ <|> reserved objc "CF_INLINE"
+ t <- type_no_pointers
+ (n, tf) <- id_declarator
+ skipBlock
+ return []
Modified: trunk/hoc/InterfaceGenerator2/Preprocessor.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Preprocessor.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Preprocessor.hs Sun Sep 28 13:58:13 2008
@@ -1,9 +1,9 @@
module Preprocessor( preprocess ) where
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Token
-import Text.ParserCombinators.Parsec.Language(emptyDef)
-import Text.ParserCombinators.Parsec.Expr
+import Text.Parsec
+import Text.Parsec.Token
+import Text.Parsec.Language(emptyDef)
+import Text.Parsec.Expr
import Control.Monad.State as StateM
@@ -54,7 +54,7 @@
expression = try (buildExpressionParser optable basic) <|> return (return
0)
where
- basic :: CharParser () Expr
+ basic :: Parsec String () Expr
basic = do i <- integer cpp
return (return i)
<|> do reserved cpp "defined"
@@ -145,7 +145,15 @@
parseDirectives = map (\l -> case parse line "" l of
Left e -> Text $ l ++ "// " ++ show (show
e)
- Right x -> x) . lines . unblockComments
+ Right x -> x) . handleBackslashes .
lines . unblockComments
+
+handleBackslashes [] = []
+handleBackslashes (l : ls)
+ | null l = [] : handleBackslashes ls
+ | last l == '\\' = case handleBackslashes ls of
+ (l2 : ls') -> (l ++ '\n' : l2) : ls'
+ ls' -> ls'
+ | otherwise = l : handleBackslashes ls
preprocess fn f = execute fn $ parseDirectives f
|
|
From: <cod...@go...> - 2008-09-28 18:52:27
|
Author: wol...@gm...
Date: Sun Sep 28 11:51:23 2008
New Revision: 316
Modified:
trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
Log:
Also accept built-in integer types as base types for enums
Bindings generated from OSX 10.5 SDK now compile.
Modified: trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/HackEnumNames.hs (original)
+++ trunk/hoc/InterfaceGenerator2/HackEnumNames.hs Sun Sep 28 11:51:23 2008
@@ -12,9 +12,9 @@
hackEnums1 :: (a -> Maybe Declaration) -> (Declaration -> a) ->
[a] -> [a]
hackEnums1 unwrap wrap (x : y : xs)
| Just (CTypeDecl (CTEnum name1 vals)) <- unwrap x,
- Just (Typedef (CTSimple baseType) name2) <- unwrap y,
+ Just (Typedef baseType name2) <- unwrap y,
null name1 || name1 == name2 || name1 == '_' : name2,
- baseType == "NSInteger" || baseType == "NSUInteger"
+ acceptableEnumBaseType baseType
= wrap (Typedef (CTEnum name1 vals) name2)
: hackEnums1 unwrap wrap xs
hackEnums1 unwrap wrap (x : xs)
@@ -27,3 +27,8 @@
decl other = Nothing
hackEnums1 unwrap wrap [] = []
+ acceptableEnumBaseType (CTSimple name)
+ | name == "NSInteger" || name == "NSUInteger" = True
+ acceptableEnumBaseType (CTBuiltin _ _ name)
+ | name == "int" = True
+ acceptableEnumBaseType _ = False
|
|
From: <cod...@go...> - 2008-09-28 17:41:16
|
Author: wol...@gm...
Date: Sun Sep 28 10:40:43 2008
New Revision: 315
Modified:
trunk/hoc/HOC.cabal
trunk/hoc/InterfaceGenerator2/Headers.hs
trunk/hoc/InterfaceGenerator2/Main.hs
Log:
Command line option improvements:
allow to specify SDK on command line
add --dump-preprocessed and --dump-parsed options for debugging
Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal (original)
+++ trunk/hoc/HOC.cabal Sun Sep 28 10:40:43 2008
@@ -67,6 +67,7 @@
main-is: Main.hs
hs-source-dirs: HOC, InterfaceGenerator2
+ build-depends: filepath
if flag(BinaryInterfaces)
build-depends: binary >= 0.2
cpp-options: -DBINARY_INTERFACES
Modified: trunk/hoc/InterfaceGenerator2/Headers.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Headers.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Headers.hs Sun Sep 28 10:40:43 2008
@@ -1,9 +1,14 @@
-module Headers where
+module Headers( ModuleName,
+ HeaderInfo(..),
+ headersIn,
+ headersForFramework,
+ loadHeaders ) where
import Parser(header)
import SyntaxTree(Declaration)
import Control.Exception(evaluate)
+import Control.Monad(when)
import Data.Char(isAlphaNum, toUpper)
import Data.List(isPrefixOf,isSuffixOf,partition)
import Data.Maybe(mapMaybe)
@@ -14,6 +19,7 @@
import qualified Data.ByteString.Char8 as BS
import Progress
import Preprocessor
+import System.FilePath
type ModuleName = ByteString
data HeaderInfo = HeaderInfo ModuleName [ModuleName] [Declaration]
@@ -42,14 +48,13 @@
headersIn dirName prefix = do
files <- getDirectoryContents dirName
- return [ (fn, dirName ++ fn, haskellizeModuleName $
+ return [ (fn, dirName </> fn, haskellizeModuleName $
prefix ++ "." ++ takeWhile (/= '.') fn)
| fn <- files, ".h" `isSuffixOf` fn {- , fn /= (prefix ++ ".h")
-} ]
-headersForFramework framework =
+headersForFramework prefix framework =
if System.Info.os == "darwin"
- -- then headersIn ("/System/Library/Frameworks/" ++ framework
++ ".framework/Headers/") framework
- then headersIn
("/Developer/SDKs/MacOSX10.4u.sdk/System/Library/Frameworks/" ++ framework
++ ".framework/Headers/") framework
+ then headersIn (prefix </> "System/Library/Frameworks" </>
(framework ++ ".framework") </> "Headers") framework
else headersIn ("/usr/lib/GNUstep/System/Library/Headers/" ++
framework ++ "/") framework
translateObjCImport imp = haskellizeModuleName $
@@ -58,16 +63,18 @@
slashToDot '/' = '.'
slashToDot c = c
-loadHeaders progress headers =
+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 {-
stripPreprocessor -} contents
+ when dumpPreprocessed $ writeFile ("preprocessed-" ++
headerFileName) $ preprocessed
result <- case parse header headerFileName preprocessed of
Left err -> error $ show err
- Right decls ->
+ Right decls -> do
+ when dumpParsed $ writeFile ("parsed-" ++
headerFileName) $ unlines $ map show decls
return $ HeaderInfo (BS.pack moduleName)
(map (BS.pack .
translateObjCImport) imports) decls
reportProgress progress nHeaders
Modified: trunk/hoc/InterfaceGenerator2/Main.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Main.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Main.hs Sun Sep 28 10:40:43 2008
@@ -9,6 +9,7 @@
import System.IO
import System.Environment ( getArgs )
import System.Console.GetOpt
+import System.FilePath ( (</>) )
import Control.Exception ( finally )
import Messages
@@ -116,7 +117,10 @@
oAdditionalCode :: Maybe String,
oShowZapped :: Bool,
oDumpInitial :: Bool,
- oQuiet :: Bool
+ oQuiet :: Bool,
+ oPrefix :: String,
+ oDumpPreprocessed :: Bool,
+ oDumpParsed :: Bool
}
processFramework :: Options -> IO ()
@@ -156,11 +160,12 @@
headers <- fmap concat $ flip mapM (oHeaderDirectories options) $
\hd -> case hd of
FrameworkHeaders framework
- -> headersForFramework framework
+ -> headersForFramework (oPrefix options)
framework
Headers path
-> headersIn path (oFrameworkName options)
- loaded <- loadHeaders parseProgress headers
+ loaded <- loadHeaders (oDumpPreprocessed options, oDumpParsed
options)
+ parseProgress headers
let enumHacked = map hackEnumNames loaded
@@ -277,9 +282,25 @@
"dump all entities after parsing",
Option ['q'] ["quiet"]
(NoArg (\o -> o { oQuiet = True }))
- "don't report progress"
+ "don't report progress",
+ Option ['p'] ["prefix"]
+ (ReqArg (\p o -> o { oPrefix = p }) "path")
+ "prefix for system framework paths",
+ Option ['s'] ["sdk"]
+ (ReqArg (\sdk o -> o { oPrefix = sdkDirectory sdk }) "sdk")
+ "name of SDK to use",
+ Option [] ["dump-preprocessed"]
+ (NoArg (\o -> o { oDumpPreprocessed = True }))
+ "dump preprocessor result to many little files",
+ Option [] ["dump-parsed"]
+ (NoArg (\o -> o { oDumpParsed = True }))
+ "dump parse result to many little files"
+
]
+sdkDirectory sdk = "/Developer/SDKs"
+ </> (sdk ++ ".sdk")
+
main :: IO ()
main = do
args <- getArgs
@@ -294,7 +315,10 @@
oAdditionalCode = Nothing,
oShowZapped = False,
oDumpInitial = False,
- oQuiet = False
+ oQuiet = False,
+ oPrefix = "/",
+ oDumpPreprocessed = False,
+ oDumpParsed = False
}
options = foldl (flip ($)) options0 optionsF
in
|
|
From: <cod...@go...> - 2008-09-28 17:36:15
|
Author: wol...@gm...
Date: Sun Sep 28 10:35:32 2008
New Revision: 314
Modified:
trunk/hoc/HOC/HOC/SelectorNameMangling.hs
Log:
Missing part of r309
Modified: trunk/hoc/HOC/HOC/SelectorNameMangling.hs
==============================================================================
--- trunk/hoc/HOC/HOC/SelectorNameMangling.hs (original)
+++ trunk/hoc/HOC/HOC/SelectorNameMangling.hs Sun Sep 28 10:35:32 2008
@@ -29,12 +29,10 @@
-}
-{-
-- addObject:forKey: -> addObject_forKey_
-- close: -> close_
-mangleSelectorName = forceLowercase . uncolon
+mangleSelectorNameWithUnderscores = forceLowercase . uncolon
where
uncolon = map f where f ':' = '_' ; f x = x
forceLowercase xs = map toLower (takeWhile isUpper xs) ++
dropWhile isUpper xs
--}
\ No newline at end of file
|
|
From: <cod...@go...> - 2008-09-28 16:39:08
|
Author: wol...@gm...
Date: Sun Sep 28 09:37:57 2008
New Revision: 313
Modified:
trunk/hoc/InterfaceGenerator2/BuildEntities.hs
trunk/hoc/InterfaceGenerator2/Parser.hs
trunk/hoc/InterfaceGenerator2/SyntaxTree.hs
Log:
Improve the parser:
* parse ObjC 2.0 @property declarations (not handled in the other parts of
ifgen yet)
* more complete C type parsing, including function pointer types
* various small fixes
Also, the parser is now good enough that it can parse all of
Foundation, QuartzCore, AppKit and CoreData without skipping any
declarations;
from now on, declarations that we cannot parse will be reported as errors.
Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs Sun Sep 28 09:37:57 2008
@@ -135,7 +135,7 @@
= makeSelectorEntity True modName clsID clsName sel
makeEntitiesForSelectorListItem modName _clsID _clsName (LocalDecl
decl)
= makeEntity modName decl >> return Nothing
- makeEntitiesForSelectorListItem _modName _clsID _clsName
PropertyDecl
+ makeEntitiesForSelectorListItem _modName _clsID _clsName
(PropertyDecl _)
= return Nothing
makeEntitiesForSelectorListItem _modName _clsID _clsName (Required
_)
= return Nothing
Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs Sun Sep 28 09:37:57 2008
@@ -1,8 +1,8 @@
-module Parser where
+module Parser( header, selector ) where
-import Data.Maybe(catMaybes, isJust)
+import Data.Maybe(catMaybes, isJust, fromJust)
import Data.Char(ord, isUpper, isDigit)
-import Data.Bits(shiftL)
+import Data.Bits(shiftL, (.|.))
import Control.Monad(guard)
import Text.ParserCombinators.Parsec
@@ -23,20 +23,27 @@
, identLetter = alphaNum <|> char '_'
, reservedNames =
["@class","@protocol","@interface","@implementation","@end","@property",
"const", "volatile", "struct", "union", "enum",
- "@required", "@optional"]
+ "__attribute__", "__strong",
+ "@required", "@optional", "@private", "@public" ]
, caseSensitive = True
}
objc :: TokenParser ()
objc = makeTokenParser objcDef
+singleton x = [x]
+
+header :: Parser [Declaration]
-header = try (whiteSpace objc >> eof >> return []) <|> (
- fmap catMaybes $ many (whiteSpace objc >>
- (try interestingThing
- <|> uninterestingThing))
- )
+header = do
+ optional (whiteSpace objc)
+ fmap concat $ many $ do
+ -- thing <- try interestingThing <|> uninterestingThing -- lenient
parsing
+ thing <- interestingThing -- strict parsing
+ optional (whiteSpace objc)
+ return thing
+uninterestingThing :: Parser (Maybe Declaration)
uninterestingThing = skipMany1 (satisfy (\x -> x /= '@' && x /= ';')) >>
return Nothing
interestingThing =
@@ -44,22 +51,23 @@
<|> (try protocol_decl)
<|> interface_decl
<|> empty_decl
- <|> (fmap Just type_declaration)
- <|> (fmap Just extern_decl)
+ <|> type_declaration
+ <|> extern_decl
+ <|> (semi objc >> return [])
-empty_decl = semi objc >> return Nothing
+empty_decl = semi objc >> return []
class_decl = do
reserved objc "@class"
classes <- commaSep1 objc (identifier objc)
semi objc
- return $ Just $ ForwardClass classes
+ return [ForwardClass classes]
protocol_decl = do
reserved objc "@protocol"
protos <- commaSep1 objc (identifier objc)
semi objc
- return $ Just $ ForwardProtocol protos
+ return [ForwardProtocol protos]
interface_decl = do
proto <- (reserved objc "@interface" >> return False)
@@ -79,9 +87,9 @@
return $ Interface class_name super protos
)
instance_variables
- selectors <- many selectorListItem
+ selectors <- fmap concat $ many selectorListItem
reserved objc "@end"
- return $ Just $ SelectorList what selectors
+ return [SelectorList what selectors]
category_spec = parens objc (identifier objc)
@@ -98,11 +106,12 @@
instance_variables = skipBlock <|> return ()
selectorListItem
- = selector
- <|> (fmap LocalDecl type_declaration)
- <|> fmap LocalDecl extern_decl
- <|> property
- <|> requiredOrOptional
+ = fmap singleton selector
+ <|> fmap (map LocalDecl) type_declaration
+ <|> fmap (map LocalDecl) extern_decl
+ <|> property_declaration
+ <|> fmap singleton requiredOrOptional
+ <|> (semi objc >> return [])
requiredOrOptional
= (reserved objc "@required" >> return (Required True))
@@ -135,37 +144,103 @@
semi objc
return (classOrInstanceMethod $ Selector name rettype types vararg)
-property
+property_declaration
= do
reserved objc "@property"
- optional (parens objc (identifier objc))
+ properties <- option [] (parens objc (commaSep objc $
property_attribute))
basetype <- type_no_pointers
- args <- commaSep objc varname_with_stars
+ things <- commaSep objc id_declarator
+ availability
semi objc
- return PropertyDecl
+ return $ map (\ (name, typeModifiers) -> PropertyDecl $
+ Property (typeModifiers $ basetype)
+ name properties ) things
+
+property_attribute =
+ (do reserved objc "getter"
+ symbol objc "="
+ name <- identifier objc
+ return $ Getter name)
+ <|> (do reserved objc "setter"
+ symbol objc "="
+ name <- identifier objc
+ symbol objc ":"
+ return $ Setter (name ++ ":"))
+ <|> (reserved objc "readonly" >> return ReadOnly)
+ <|> (reserved objc "readwrite" >> return ReadWrite)
+ <|> (reserved objc "assign" >> return Assign)
+ <|> (reserved objc "retain" >> return Retain)
+ <|> (reserved objc "copy" >> return Copy)
--- type_spec = parens objc ctype <|> return CTNoType
- -- where
- -- ctype = fmap (CType . unwords) $ many (identifier objc <|> symbol
objc "*")
-type_spec = try (parens objc ctype) <|> (skipParens >> return CTUnknown) <|
> return (CTIDType [])
+--type_spec = try (parens objc ctype) <|> (skipParens >> return CTUnknown)
<|> return (CTIDType [])
+type_spec = parens objc ctype <|> return (CTIDType [])
type_no_pointers = do -- "const char" in "const char *foo[32]"
many ignored_type_qualifier -- ignore
- simple_type
-
-varname_with_stars = do
- pointers_and_such <- many type_operator
- name <- identifier objc
- arrays <- many (symbol objc "[" >> symbol objc "]" >> return CTPointer)
- return (name, \t -> foldl (flip ($)) t (pointers_and_such ++ arrays))
+ t <- simple_type
+ many ignored_type_qualifier
+ return t
+
+id_declarator = declarator False (identifier objc)
+
+declarator :: Bool -> Parser a -> Parser (a, CType -> CType)
+declarator emptyDeclaratorPossible thing = do
+ prefixes <- many prefix_operator
+ (name, typeFun) <- terminal
+ postfixes <- many postfix_operator
+ return (name, foldl (.) typeFun (postfixes ++ prefixes))
+ where
+ mbTry | emptyDeclaratorPossible = try
+ | otherwise = id
+ terminal =
+ mbTry (parens objc (declarator emptyDeclaratorPossible
thing))
+ <|> (thing >>= \name -> return (name, id))
+ prefix_operator =
+ do
+ symbol objc "*"
+ many ignored_type_qualifier
+ return CTPointer
+
+ postfix_operator =
+ brackets objc (optional (integer objc) >> return CTPointer)
+ <|> do
+ (args, vararg) <- parens objc arguments
+ return (\retval -> CTFunction retval args vararg)
+
+ arguments =
+ do
+ args <- commaSep objc argument
+ case reverse args of
+ (Nothing : moreArgs)
+ | all isJust moreArgs ->
+ return (map fromJust $ reverse moreArgs, True)
+ _ | all isJust args -> return (map fromJust args,
False)
+ | otherwise -> fail "'...' in the middle of
argument list"
+ where
+ argument =
+ (symbol objc "..." >> return Nothing)
+ <|> do
+ t <- type_no_pointers
+ (_, tf) <- declarator True (optional $ identifier
objc)
+ return $ Just $ tf t
+
+
+testdecl :: String -> IO ()
+testdecl s = case parse (declarator True (return ()){- (identifier
objc)-}) "" s of
+ Right (n, t) -> print $ t (CTSimple "void")
+ Left e -> print e
ctype = do
simple <- type_no_pointers
- pointers_and_such <- many type_operator
- return $ foldl (flip ($)) simple pointers_and_such
+ (_, f) <- declarator True (return ())
+ return (f simple)
-simple_type = id_type <|> enum_type <|> struct_type <|> try builtin_type <|
> fmap CTSimple (identifier objc)
+simple_type = id_type <|> enum_type <|> struct_type <|> try builtin_type
+ <|> do
+ n <- identifier objc
+ protos <- protocol_spec -- TOOD: use these protocols
+ return $ CTSimple n
builtin_type = do
signedness <- (reserved objc "signed" >> return (Just True))
@@ -191,6 +266,7 @@
protos <- protocol_spec
return $ CTIDType protos
+
multiCharConstant =
lexeme objc (between (char '\'') (char '\'') multiChars)
where
@@ -201,14 +277,26 @@
(iterate (*256) 1)
-const_int_expr env = buildExpressionParser optable basic
+suffixedInteger =
+ do
+ val <- integer objc
+ optional (reserved objc "U" <|> reserved objc "L"
+ <|> reserved objc "UL") -- ### TODO: no space allowed
before 'U'
+ return val
+
+const_int_expr env = expr
where
- basic = (integer objc) <|> multiCharConstant
+ expr = buildExpressionParser optable basic
+ basic = suffixedInteger
+ <|> multiCharConstant
<|> (do name <- identifier objc
Map.lookup name env)
- optable = [ [Infix shiftLeft AssocLeft] ]
+ <|> parens objc expr
+ optable = [ [Infix shiftLeft AssocLeft],
+ [Infix bitwiseOr AssocLeft] ]
shiftLeft = op "<<" (flip $ flip shiftL . fromIntegral)
+ bitwiseOr = op "|" (.|.)
op str f = reservedOp objc str >> return f
@@ -216,34 +304,47 @@
do
key <- reserved objc "enum"
id <- identifier objc <|> return ""
- body <- braces objc (enum_body Map.empty (-1)) <|> return []
+ body <- braces objc (enum_body Map.empty (Just (-1))) <|> return []
return $ CTEnum id body
where
enum_body env lastVal = do
id <- identifier objc
- val <- (do
+ mbVal <- (do
symbol objc "="
- const_int_expr env
- ) <|> return (lastVal + 1)
+ try (fmap Just $ const_int_expr env)
+ <|> (skipEnumValue >> return Nothing)
+ ) <|> return (lastVal >>= Just . (+1))
- let env' = Map.insert id val env
- xs <- option [] $ comma objc >> option [] (enum_body env' val)
- return $ (id, GivenValue val) : xs
+ case mbVal of
+ Just val -> do
+ let env' = Map.insert id val env
+ xs <- option [] $ comma objc
+ >> option [] (enum_body env' (Just
val))
+ return $ (id, GivenValue val) : xs
+ Nothing -> do
+ xs <- option [] $ comma objc
+ >> option [] (enum_body env Nothing)
+ return $ (id, TooComplicatedValue "") : xs
struct_type =
do
key <- (reserved objc "struct" >> return CTStruct)
<|> (reserved objc "union" >> return CTUnion)
id <- identifier objc <|> return ""
- body <- braces objc struct_union_body <|> return []
+ body <- fmap concat $ braces objc struct_union_body <|> return []
return $ key id body
where
- struct_union_body = many member
+ struct_union_body = try (many member)
+ <|> (skipBlockContents >> return [])
member = do
- typ <- ctype
- name <- identifier objc
+ typ <- type_no_pointers
+ things <- commaSep objc $ do
+ (name, typeModifiers) <- id_declarator
+ bitfield <- option Nothing
+ (symbol objc ":" >> integer objc >>= return . Just)
+ return (name, typeModifiers)
semi objc
- return (typ, name)
+ return [ (modifier typ, name) | (name, modifier) <- things ]
type_operator =
(symbol objc "*" >> return CTPointer)
@@ -258,43 +359,52 @@
<|> reserved objc "bycopy"
<|> reserved objc "byref"
<|> reserved objc "oneway"
+ <|> reserved objc "__strong"
typedef = do
reserved objc "typedef"
- oldType <- ctype
- newType <- identifier objc
- semi objc
- return $ Typedef oldType newType
+ baseType <- type_no_pointers
+ newTypes <- commaSep objc id_declarator
+ availability
+ semi objc
+ return $ [Typedef (typeFun baseType) name
+ | (name, typeFun) <- newTypes ]
+
ctypeDecl = do
typ <- enum_type <|> struct_type
+ availability
semi objc
- return $ CTypeDecl typ
+ return [CTypeDecl typ]
type_declaration = typedef <|> ctypeDecl
extern_decl =
- extern_keyword >> ctype >>= \t -> identifier objc >>= \n ->
- do
- args <- parens objc (commaSep objc argument)
- availability
- semi objc
- return $ ExternFun (Selector n t args False)
- <|> do
- availability
- semi objc
- return $ ExternVar t n
+ do
+ extern_keyword
+ t <- type_no_pointers
+ vars <- commaSep objc (one_var t)
+ availability
+ semi objc
+ return vars
where
- argument = do t <- ctype
- optional (identifier objc)
- arrays <- many (symbol objc "[" >> symbol objc "]"
>> return CTPointer)
- return $ foldl (flip ($)) t arrays
-
+ one_var t = do
+ (n, typeOperators) <- id_declarator
+ return $ case typeOperators t of
+ CTFunction retval args varargs
+ -> ExternFun (Selector n retval args varargs)
+ otherType
+ -> ExternVar otherType n
+
availability = optional $
+ do reserved objc "__attribute__"
+ parens objc (skipParens)
+ return ()
+ <|>
do x <- identifier objc
guard $ all (\c -> isUpper c || isDigit c || c == '_') x
-- guard (any (`isPrefixOf` x) ["AVAILABLE_MAC_", "DEPRECATED_IN_"])
-
+
extern_keyword =
reserved objc "extern"
<|> reserved objc "FOUNDATION_EXPORT" -- N.B. "Export" vs. "Extern".
@@ -306,8 +416,10 @@
<|> skipParens
))
-skipBlock = braces objc (skipMany (
+skipBlockContents = (skipMany (
(satisfy (\x -> x /= '{' && x /= '}') >> return ())
<|> skipBlock
))
+skipBlock = braces objc skipBlockContents
+skipEnumValue = skipMany1 (satisfy (\x -> x /= '}' && x /= ','))
Modified: trunk/hoc/InterfaceGenerator2/SyntaxTree.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/SyntaxTree.hs (original)
+++ trunk/hoc/InterfaceGenerator2/SyntaxTree.hs Sun Sep 28 09:37:57 2008
@@ -23,7 +23,7 @@
InstanceMethod Selector
| ClassMethod Selector
| LocalDecl Declaration
- | PropertyDecl
+ | PropertyDecl Property
| Required Bool
deriving (Show,Eq,Ord)
@@ -36,12 +36,27 @@
}
deriving (Read,Show,Eq,Ord,Typeable,Data)
+data Property = Property CType String [PropertyAttribute]
+ deriving (Show, Eq, Ord)
+
+data PropertyAttribute =
+ Getter String
+ | Setter String
+ | ReadOnly
+ | ReadWrite
+ | Assign
+ | Retain
+ | Copy
+ deriving (Show, Eq, Ord)
+
+
data EnumValue = NextValue | GivenValue Integer | TooComplicatedValue
String
deriving (Read, Show, Eq, Ord,Typeable,Data)
data CType = CTIDType [String {- protocols -}]
| CTSimple String
| CTPointer CType
+ | CTFunction CType [CType] Bool
| CTUnknown
| CTEnum String [(String, EnumValue)]
| CTStruct String [(CType, String)]
|
|
From: <cod...@go...> - 2008-09-25 23:36:24
|
Author: wol...@gm...
Date: Thu Sep 25 16:35:43 2008
New Revision: 312
Modified:
trunk/hoc/InterfaceGenerator2/BindingScript.hs
trunk/hoc/InterfaceGenerator2/BuildEntities.hs
trunk/hoc/InterfaceGenerator2/DependenceGraphs.hs
trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs
trunk/hoc/InterfaceGenerator2/Entities.hs
trunk/hoc/InterfaceGenerator2/Files.hs
trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
trunk/hoc/InterfaceGenerator2/Main.hs
trunk/hoc/InterfaceGenerator2/Messages.hs
trunk/hoc/InterfaceGenerator2/Output.hs
trunk/hoc/InterfaceGenerator2/Preprocessor.hs
trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
Log:
Some general cleanup.
Modified: trunk/hoc/InterfaceGenerator2/BindingScript.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BindingScript.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BindingScript.hs Thu Sep 25 16:35:43 2008
@@ -38,7 +38,8 @@
soHiddenSelectors :: Set String,
soChangedSelectors :: Map.Map String Selector
}
-
+
+emptyBindingScript :: BindingScript
emptyBindingScript
= BindingScript {
bsHiddenFromPrelude = Set.empty,
@@ -52,7 +53,8 @@
bsAdditionalTypes = [],
bsClassSpecificOptions = Map.empty
}
-
+
+defaultNameMappings :: Map.Map String String
defaultNameMappings = Map.fromList [
("data", "data'"),
("type", "type'"),
@@ -78,8 +80,10 @@
where
top = bsTopLevelOptions bindingScript
+tokenParser :: TokenParser ()
tokenParser = makeTokenParser $ haskellStyle { identStart = letter <|>
char '_' }
+selector, qualified :: TokenParser () -> Parser String
selector tp = lexeme tp $ do
c <- letter <|> char '_'
s <- many (alphaNum <|> oneOf "_:")
@@ -163,6 +167,7 @@
eof
let wrongThings = [ () | ReplaceSelector _ <- statements ]
+ when (not $ null wrongThings) $ fail "illegal thing at top level"
return $ BindingScript {
bsHiddenFromPrelude = Set.fromList [ ident | HidePrelude ident
<- statements ],
Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs Thu Sep 25 16:35:43 2008
@@ -43,6 +43,7 @@
makeEntities :: BindingScript -> [HeaderInfo] -> EntityPile -> EntityPile
+assertHaskellTypeName :: BS.ByteString -> BS.ByteString
assertHaskellTypeName xs
| not (BS.null xs)
&& isUpper x && BS.all (\c -> isAlphaNum c || c `elem` "_'") xs
@@ -86,7 +87,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 factory modName _clsID clsName sel
= if hidden
then return Nothing
else do
@@ -132,11 +133,11 @@
= makeSelectorEntity False modName clsID clsName sel
makeEntitiesForSelectorListItem modName clsID clsName (ClassMethod
sel)
= makeSelectorEntity True modName clsID clsName sel
- makeEntitiesForSelectorListItem modName clsID clsName (LocalDecl
decl)
+ makeEntitiesForSelectorListItem modName _clsID _clsName (LocalDecl
decl)
= makeEntity modName decl >> return Nothing
- makeEntitiesForSelectorListItem modName clsID clsName PropertyDecl
+ makeEntitiesForSelectorListItem _modName _clsID _clsName
PropertyDecl
= return Nothing
- makeEntitiesForSelectorListItem modName clsID clsName (Required _)
+ makeEntitiesForSelectorListItem _modName _clsID _clsName (Required
_)
= return Nothing
makeSelectorEntities modName clsID clsName items
@@ -203,11 +204,11 @@
eModule = LocalModule modName
}
) >> return ()
- makeEntity modName (Typedef (CTStruct n2 fields) name)
+ makeEntity _modName (Typedef (CTStruct _n2 _fields) _name)
= return ()
- makeEntity modName (Typedef (CTUnion n2 fields) name)
+ makeEntity _modName (Typedef (CTUnion _n2 _fields) _name)
= return ()
- makeEntity modName (Typedef (CTEnum n2 vals) name)
+ makeEntity modName (Typedef (CTEnum _n2 vals) name)
| notHidden name
= makeEnum name modName vals
-- makeAnonymousEnum modName vals -- ### HACK for 10.5:
ignore enum names
@@ -250,7 +251,7 @@
return ()
where name = selName sel
- makeEntity modName _ = return ()
+ makeEntity _modName _ = return ()
convertEnumEntities :: [(String, EnumValue)]
-> (Bool, [(BS.ByteString, Integer)])
Modified: trunk/hoc/InterfaceGenerator2/DependenceGraphs.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/DependenceGraphs.hs (original)
+++ trunk/hoc/InterfaceGenerator2/DependenceGraphs.hs Thu Sep 25 16:35:43
2008
@@ -1,9 +1,10 @@
module DependenceGraphs(
- entitiesRequiredByEntity,
RGr,
- makeEntityGraph,
+ -- used by DuplicateEntities:
+ makeModuleDAG,
+ -- used by Output & Main:
+ entitiesRequiredByEntity,
makeModuleGraph,
- makeModuleDAG,
topsortEntities,
minimizeSourceImports,
isSourceImport
@@ -25,28 +26,6 @@
= mentionedEntityIDs e
type RGr a b = (Gr a b, Map.Map a Node)
-
-makeEntityGraph :: EntityPile -> RGr EntityID Bool
-makeEntityGraph entityPile
- = (gr, entityToNode)
- where
- entities = localEntities entityPile
- entityToNode = Map.fromList $ zip (Map.keys entities) [1..]
- gr = mkGraph (zip [1..] (Map.keys entities)) $
- do {- list -}
- (fromEntityID, e) <- Map.toList entities
- let from = entityToNode Map.! fromEntityID
- weak = case eInfo e of
- ProtocolEntity _ _ -> True
- _ -> False
- toEntityID <- entitiesRequiredByEntity e
-
- case toEntityID of
- LocalEntity _ ->
- return (from, entityToNode Map.! toEntityID,
- weak)
- FrameworkEntity _ _ ->
- []
makeModuleGraph :: EntityPile -> RGr Module Bool
makeModuleGraph entityPile
Modified: trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs Thu Sep 25 16:35:43
2008
@@ -61,6 +61,7 @@
redirect eid = fromMaybe eid $ Map.lookup eid remappings
+combineDulicateEntities :: EntityPile -> EntityPile
combineDulicateEntities entityPile
= resolve entityPile
where
Modified: trunk/hoc/InterfaceGenerator2/Entities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Entities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Entities.hs Thu Sep 25 16:35:43 2008
@@ -95,7 +95,7 @@
addImportedEntities :: ModuleName -> EntityMap
-> EntityPile -> EntityPile
-addImportedEntities mod entities pile
+addImportedEntities _mod entities pile
= pile { epFrameworkEntities = entities `Map.union`
epFrameworkEntities pile }
newEntity :: MonadState EntityPile m => Entity -> m EntityID
@@ -147,33 +147,15 @@
transformLocalEntities :: (EntityMap -> EntityMap)
-> EntityPile -> EntityPile
-{-transformLocalEntities f (EntityPile entities nextID)
- = EntityPile (fwEntities `Map.union` localEntities') nextID
- where
- (fwEntities, localEntities)
- = Map.partitionWithKey isFramework entities
- localEntities' = f localEntities
-
- isFramework (FrameworkEntity _ _) _ = True
- isFramework _ _ = False-}
transformLocalEntities f pile
= pile { epEntities = f (epEntities pile) }
--- transformLocalEntities f = f
-localEntities :: EntityPile -> EntityMap
-{-
-localEntities = Map.filterWithKey notFramework . epEntities
- where
- notFramework (FrameworkEntity _ _) _ = False
- notFramework _ _ = True
--}
+localEntities, frameworkEntities :: EntityPile -> EntityMap
localEntities = epEntities
frameworkEntities = epFrameworkEntities
replaceLocalEntities :: EntityMap -> EntityPile -> EntityPile
replaceLocalEntities locals = transformLocalEntities (const locals)
--- localEntityPile :: EntityPile -> EntityPile
--- localEntityPile pile = EntityPile (localEntities pile) (epNextID pile)
-
+reportProgressForPile :: ProgressReporter -> EntityPile -> EntityPile
reportProgressForPile pr = transformLocalEntities (reportProgressForMap pr)
Modified: trunk/hoc/InterfaceGenerator2/Files.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Files.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Files.hs Thu Sep 25 16:35:43 2008
@@ -1,10 +1,6 @@
module Files(
- additionalCodePath,
- outputPath,
writeFileIfChanged,
- readFileOrEmpty,
createDirectoryIfNecessary,
- createOutputDirectories,
createParentDirectoriesIfNecessary
) where
@@ -14,11 +10,7 @@
doesFileExist,
createDirectory)
-outputDir = "ifgen-output"
-outputPath f = outputDir ++ "/" ++ f
-
-additionalCodePath f = "AdditionalCode/" ++ f
-
+writeFileIfChanged :: FilePath -> String -> IO ()
writeFileIfChanged fn text = do
exists <- doesFileExist fn
if exists
@@ -29,10 +21,12 @@
writeFile fn text
else writeFile fn text
+createDirectoryIfNecessary :: FilePath -> IO ()
createDirectoryIfNecessary dir = do
exists <- doesDirectoryExist dir
unless exists $ createDirectory dir
+createParentDirectoriesIfNecessary :: FilePath -> IO ()
createParentDirectoriesIfNecessary f
= work (dropWhile (/= '/') $ reverse f)
where
@@ -41,16 +35,3 @@
work fr = do
work $ dropWhile (/='/') fr
createDirectoryIfNecessary (reverse fr)
-
-createOutputDirectories frameworks = do
- createDirectoryIfNecessary outputDir
- mapM_ createDirectoryIfNecessary (map outputPath frameworks)
-
-readFileOrEmpty fn = do
- exists <- doesFileExist fn
- if exists
- then do
- contents <- readFile fn
- return $ Just contents
- else do
- return Nothing
Modified: trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/HackEnumNames.hs (original)
+++ trunk/hoc/InterfaceGenerator2/HackEnumNames.hs Thu Sep 25 16:35:43 2008
@@ -4,6 +4,8 @@
import SyntaxTree
import Headers
+hackEnumNames :: HeaderInfo -> HeaderInfo
+
hackEnumNames (HeaderInfo name imports decls)
= HeaderInfo name imports (hackEnums1 Just id decls)
where
Modified: trunk/hoc/InterfaceGenerator2/Main.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Main.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Main.hs Thu Sep 25 16:35:43 2008
@@ -1,27 +1,23 @@
{-# LANGUAGE CPP #-}
module Main where
-import Headers
+import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
import qualified Data.Set as Set
-import Control.Monad.Writer
-import BindingScript
-import Data.Char
-import Data.Maybe
--- import Data.Generics
+import Data.Maybe ( fromMaybe )
+import Control.Monad ( when )
import System.IO
+import System.Environment ( getArgs )
+import System.Console.GetOpt
+import Control.Exception ( finally )
import Messages
import Entities
--- import Traversals
+import BindingScript
import Files
import Progress
-import qualified Data.ByteString.Char8 as BS
-import System.Environment
-import System.Console.GetOpt
-import Control.Exception
#ifdef BINARY_INTERFACES
import Data.Binary ( encodeFile, decode )
@@ -29,26 +25,23 @@
import qualified Data.ByteString.Lazy as LBS
#endif
-import HackEnumNames
-import BuildEntities
+
+import Headers -- (on disk) -> [HeaderInfo]
+import HackEnumNames -- HeaderInfo -> HeaderInfo
+import BuildEntities -- [HeaderInfo] -> EntityPile
+
+ -- EntityPile -> EntityPile passes
import ResolveAndZap
-import DependenceGraphs
import ShuffleInstances
import DuplicateEntities
-import Output
-
-textInterfaces = False -- Overall 3 times faster with binary
-
-{-deepEvaluatePile = mapM_ deepEvaluateEntity . Map.elems . localEntities
-evalWithProgress str pile
- = runShowingProgress str $
- \progress -> deepEvaluatePile $ reportProgressForPile progress $
pile
--}
+import DependenceGraphs
+import Output
instance Monitorable EntityPile where
monitor pr = transformLocalEntities (monitor pr)
+writeFrameworkModules :: ProgressReporter -> EntityPile -> FilePath -> IO
()
writeFrameworkModules progress entityPile path
= do
let byModule = makeEntityPileLocalMultiIndex eModule $
@@ -62,8 +55,8 @@
modGraph = minimizeSourceImports $ makeModuleGraph entityPile
- flip mapM_ (zip [0..] $ Map.toList byModule) $
- \(index, (mod, entityID)) -> do
+ flip mapM_ (Map.toList byModule) $
+ \(mod, entityID) -> do
case mod of
FrameworkModule _ _ -> return ()
LocalModule modName -> do
@@ -76,6 +69,7 @@
show $ pprHsModule entityPile modGraph modName
entities
reportProgress progress nModules
+readFileWithProgress :: ProgressReporter -> FilePath -> IO String
readFileWithProgress progress fn
= do
bs <- BS.readFile fn
@@ -83,6 +77,7 @@
return $ monitorList progress n $ BS.unpack bs
#ifdef BINARY_INTERFACES
+decodeFileWithProgress :: ProgressReporter -> FilePath -> IO EntityMap
decodeFileWithProgress progress fn
= do
bs <- fmap LBS.toChunks $ LBS.readFile fn
@@ -90,6 +85,7 @@
return $ decode $ LBS.fromChunks $ monitorList progress n $ bs
#endif
+readInterfaceFileWithProgress :: ProgressReporter -> FilePath -> IO
EntityMap
readInterfaceFileWithProgress progress fn
#ifdef BINARY_INTERFACES
= decodeFileWithProgress progress fn
@@ -97,6 +93,7 @@
= fmap read $ readFileWithProgress progress fn
#endif
+writeInterfaceFileWithProgress :: ProgressReporter -> FilePath ->
EntityPile -> IO ()
writeInterfaceFileWithProgress progress fn entities
#ifdef BINARY_INTERFACES
= encodeFile fn $
@@ -122,6 +119,7 @@
oQuiet :: Bool
}
+processFramework :: Options -> IO ()
processFramework options -- bs frameworkName requiredFrameworks
= do
bs <- maybe (return emptyBindingScript) readBindingScript $
@@ -232,12 +230,14 @@
putStrLn $ "done."
-
+addRequiredFramework :: String -> Options -> Options
addRequiredFramework fw o
= o { oRequiredFrameworks = fw : oRequiredFrameworks o }
+addHeaderDirectory :: HeaderDirectory -> Options -> Options
addHeaderDirectory hd o
= o { oHeaderDirectories = hd : oHeaderDirectories o }
-
+
+optionDescs :: [OptDescr (Options -> Options)]
optionDescs = [
Option ['d'] ["depend"]
(ReqArg addRequiredFramework
@@ -279,6 +279,8 @@
(NoArg (\o -> o { oQuiet = True }))
"don't report progress"
]
+
+main :: IO ()
main = do
args <- getArgs
case getOpt Permute optionDescs args of
Modified: trunk/hoc/InterfaceGenerator2/Messages.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Messages.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Messages.hs Thu Sep 25 16:35:43 2008
@@ -18,9 +18,6 @@
helper (UnitBag x) xs = x : xs
helper (BagOfTwo a b) xs = helper a $ helper b xs
-nullBag EmptyBag = True
-nullBag _ = False
-
instance Monoid (Bag a) where
mempty = EmptyBag
mappend EmptyBag b = b
Modified: trunk/hoc/InterfaceGenerator2/Output.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Output.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Output.hs Thu Sep 25 16:35:43 2008
@@ -204,14 +204,14 @@
pprEntity e@(Entity { eInfo = EnumEntity complete constants })
= char '$' <> parens (
declare <+> brackets (
- hcat $ punctuate comma $ map pprAssoc constants
- )
+ hcat $ punctuate comma $ map pprAssoc constants
+ )
)
- where
+ where
declare = case eName e of
CName cname -> text "declareCEnum" <+> doubleQuotes
(textBS cname)
Anonymous -> text "declareAnonymousCEnum"
- pprAssoc (n, v)
+ pprAssoc (n, v)
= parens (doubleQuotes (textBS n) <> comma <+> integer
v)
pprEntity e@(Entity { eInfo = AdditionalCodeEntity _ _ _ txt })
Modified: trunk/hoc/InterfaceGenerator2/Preprocessor.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Preprocessor.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Preprocessor.hs Thu Sep 25 16:35:43 2008
@@ -107,10 +107,6 @@
execute filename xs = unlines $ evalState (exec xs []) macros where
exec (If e : xs) state@( (_, False) : _ )
= output "//#if" $ exec xs ((PPSIf False, False) : state)
--- exec (Elif e : xs) state@( (PPSIf False, False) : (_, False) : _ )
--- = output "//#elif" $ exec xs state
--- exec (Else : xs) state@( (_, False) : _ )
--- = output "//#else" $ exec xs ((PPSElse, False) : state)
exec (Text t : xs) state@( (_, False) : _ )
= output ("//T " ++ t) $ exec xs state
exec (Endif : xs) (_ : state)
@@ -139,16 +135,6 @@
return (t : moreText)
-test = putStrLn $ execute "test" $ parseDirectives
- "#include <foo>\n\
- \blah\n\
- \foo bar\n\
- \#if 1\n\
- \baz\n\
- \#else\n\
- \quux\n\
- \#endif\n"
-
unblockComments ('/' : '*' : xs) = "/*" ++ handleComment xs
where handleComment ('*' : '/' : xs) = "*/" ++ unblockComments xs
handleComment ('\n' : xs) = "*/\n/*" ++ handleComment xs
@@ -159,7 +145,20 @@
parseDirectives = map (\l -> case parse line "" l of
Left e -> Text $ l ++ "// " ++ show (show
e)
- Right x -> x) . lines . unblockComments
+ Right x -> x) . lines . unblockComments
+
+preprocess fn f = execute fn $ parseDirectives f
+
+{-
+test = putStrLn $ execute "test" $ parseDirectives
+ "#include <foo>\n\
+ \blah\n\
+ \foo bar\n\
+ \#if 1\n\
+ \baz\n\
+ \#else\n\
+ \quux\n\
+ \#endif\n"
test2 fn = do
-- f <- readFile
$ "/System/Library/Frameworks/Foundation.framework/Versions/C/Headers/" ++
fn
@@ -172,7 +171,4 @@
-- putStrLn $
putStrLn fn
print $ length $ execute fn $ parseDirectives f
-
-
-preprocess fn f = execute fn $ parseDirectives f
-
+-}
\ No newline at end of file
Modified: trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs Thu Sep 25 16:35:43 2008
@@ -103,15 +103,7 @@
_ -> zapAndReportBrokenReferences progress pile'
where
- {-
-zapAndReportFailedTypes :: ProgressReporter -> EntityPile -> Messages
EntityPile
-
-zapAndReportFailedTypes progress entityPile
- = return entityPile
- where
-
- -}
-
+zapAndReportFailedTypes :: ProgressReporter -> EntityPile -> Messages
EntityPile
zapAndReportFailedTypes progress entityPile
= zapAndReportWith worker progress entityPile
where
@@ -120,7 +112,7 @@
>> return x
reportUnconvertedType t@(UnconvertedType ctype)
- = message $ text "Coudn't convert type" -- <+> text (show
ctype)
+ = message $ text "Coudn't convert type" <+> text (show ctype)
reportUnconvertedType t
= return ()
|
|
From: <cod...@go...> - 2008-09-25 20:26:56
|
Author: wol...@gm...
Date: Thu Sep 25 13:25:56 2008
New Revision: 311
Modified:
trunk/hoc/InterfaceGenerator2/Parser.hs
Log:
Be smarter about parsing enum values.
HOC now understands references to previously-defined
enum constants in the definition of an enum constant.
For now, this is limited to constants that have been
defined in the same enum {} block.
enum
{
a = 1,
b,
c = a // <- now works
};
Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs Thu Sep 25 13:25:56 2008
@@ -12,6 +12,8 @@
import SyntaxTree
+import qualified Data.Map as Map
+
objcDef = emptyDef
{ commentStart = "/*"
, commentEnd = "*/"
@@ -197,50 +199,36 @@
return $ sum $ zipWith (*)
(map (fromIntegral.ord) $ reverse chars)
(iterate (*256) 1)
-
-const_int_expr = buildExpressionParser optable basic
+
+
+const_int_expr env = buildExpressionParser optable basic
where
- basic = fmap GivenValue (integer objc)
- <|> fmap GivenValue multiCharConstant
- <|> fmap TooComplicatedValue
- (many1 (satisfy (\x -> x /= ';' && x /= '}')))
+ basic = (integer objc) <|> multiCharConstant
+ <|> (do name <- identifier objc
+ Map.lookup name env)
optable = [ [Infix shiftLeft AssocLeft] ]
shiftLeft = op "<<" (flip $ flip shiftL . fromIntegral)
- op str f = reservedOp objc str >> return (opFun f)
- opFun f (GivenValue x) (GivenValue y) = GivenValue $ f x y
- opFun f v@(TooComplicatedValue _) _ = v
- opFun f _ v@(TooComplicatedValue _) = v
- opFun f _ _ = TooComplicatedValue "..."
-
-sloppyCommaSep lang thing
- = do
- x <- thing
- {-xs <- ( do
- comma lang
- (sloppyCommaSep lang thing <|> return [])
- <|> return []
- )-}
- xs <- option [] $ comma lang >> option [] (sloppyCommaSep lang
thing)
- return $ x : xs
-
+ op str f = reservedOp objc str >> return f
enum_type =
do
key <- reserved objc "enum"
id <- identifier objc <|> return ""
- body <- braces objc enum_body <|> return []
+ body <- braces objc (enum_body Map.empty (-1)) <|> return []
return $ CTEnum id body
where
- enum_body = sloppyCommaSep objc enum_entry
- enum_entry = do
+ enum_body env lastVal = do
id <- identifier objc
val <- (do
symbol objc "="
- const_int_expr
- ) <|> return NextValue
- return (id,val)
+ const_int_expr env
+ ) <|> return (lastVal + 1)
+
+ let env' = Map.insert id val env
+ xs <- option [] $ comma objc >> option [] (enum_body env' val)
+ return $ (id, GivenValue val) : xs
struct_type =
do
|
|
From: <cod...@go...> - 2008-09-25 20:18:57
|
Author: wol...@gm...
Date: Thu Sep 25 13:18:22 2008
New Revision: 310
Added:
trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
Modified:
trunk/hoc/InterfaceGenerator2/Main.hs
Log:
Add another pass on the newly-parsed syntax trees to recover
enum type names on Leopard. When an anonymous enum declaration
is immediately followed by a typedef of NSInteger or NSUInteger,
this is converted to a typedef of the enum instead.
This is to necessary to deal with changes Apple introduced to
improve 64-bit compatibility in Leopard.
Added: trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/InterfaceGenerator2/HackEnumNames.hs Thu Sep 25 13:18:22 2008
@@ -0,0 +1,27 @@
+{-# LANGUAGE PatternGuards #-}
+module HackEnumNames where
+
+import SyntaxTree
+import Headers
+
+hackEnumNames (HeaderInfo name imports decls)
+ = HeaderInfo name imports (hackEnums1 Just id decls)
+ where
+ hackEnums1 :: (a -> Maybe Declaration) -> (Declaration -> a) ->
[a] -> [a]
+ hackEnums1 unwrap wrap (x : y : xs)
+ | Just (CTypeDecl (CTEnum name1 vals)) <- unwrap x,
+ Just (Typedef (CTSimple baseType) name2) <- unwrap y,
+ null name1 || name1 == name2 || name1 == '_' : name2,
+ baseType == "NSInteger" || baseType == "NSUInteger"
+ = wrap (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))
+ : hackEnums1 unwrap wrap xs
+ | otherwise
+ = x : hackEnums1 unwrap wrap xs
+ where decl (LocalDecl d) = Just d
+ decl other = Nothing
+ hackEnums1 unwrap wrap [] = []
+
Modified: trunk/hoc/InterfaceGenerator2/Main.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Main.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Main.hs Thu Sep 25 13:18:22 2008
@@ -16,7 +16,6 @@
-- import Traversals
import Files
--- import Debug.Trace
import Progress
import qualified Data.ByteString.Char8 as BS
@@ -27,10 +26,10 @@
#ifdef BINARY_INTERFACES
import Data.Binary ( encodeFile, decode )
import BinaryInstances ()
-#endif
-
import qualified Data.ByteString.Lazy as LBS
+#endif
+import HackEnumNames
import BuildEntities
import ResolveAndZap
import DependenceGraphs
@@ -165,6 +164,8 @@
loaded <- loadHeaders parseProgress headers
+ let enumHacked = map hackEnumNames loaded
+
importedEMaps <- mapM (\(fn, progress) ->
readInterfaceFileWithProgress progress
("HOC-" ++ fn ++ "/" ++ fn ++ ".pi")
@@ -178,7 +179,7 @@
emptyEntityPile $
zip (map BS.pack requiredFrameworks) importedEMaps
- let initialEntities = monitor initialProgress $ makeEntities bs
loaded importedEntities
+ let initialEntities = monitor initialProgress $ makeEntities bs
enumHacked importedEntities
additionalEntities <-
|
|
From: <cod...@go...> - 2008-09-21 20:45:33
|
Author: wol...@gm...
Date: Sun Sep 21 13:44:33 2008
New Revision: 309
Added:
trunk/hoc/InterfaceGenerator2/RenameClashingIdentifiers.hs
Modified:
trunk/hoc/InterfaceGenerator2/BinaryInstances.hs
trunk/hoc/InterfaceGenerator2/BuildEntities.hs
trunk/hoc/InterfaceGenerator2/Entities.hs
trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs
Log:
Add some code to automatically resolve some name conflicts, e.g.
"move:" and "move" in the same module.
It used to be necessary to add those in binding-script for the bindings
to compile.
Modified: trunk/hoc/InterfaceGenerator2/BinaryInstances.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BinaryInstances.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BinaryInstances.hs Sun Sep 21 13:44:33
2008
@@ -159,8 +159,8 @@
_ -> fail "no parse"
instance Binary Entities.Entity where
- put (Entity a b c d) = put a >> put b >> put c >> put d
- get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return
(Entity a b c d)
+ 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
Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs Sun Sep 21 13:44:33 2008
@@ -57,6 +57,7 @@
newEntity $ Entity {
eName = CName $ BS.pack typeName,
eHaskellName = assertHaskellTypeName $ BS.pack
typeName,
+ eAlternateHaskellNames = [],
eInfo = AdditionalTypeEntity,
eModule = LocalModule $ BS.pack moduleName
}
@@ -92,6 +93,7 @@
entity <- newEntity $ Entity {
eName = SelectorName $ BS.pack name,
eHaskellName = BS.pack mangled,
+ eAlternateHaskellNames = moreMangled,
eInfo = SelectorEntity (UnconvertedType (kind,
sel')),
eModule = LocalModule modName
}
@@ -104,6 +106,10 @@
mangled = case mapped of
Just x -> x
Nothing -> mangleSelectorName name
+ moreMangled = map BS.pack $ case mapped of
+ Just _ -> [mangleSelectorName name,
mangleSelectorNameWithUnderscores name]
+ Nothing -> [mangleSelectorNameWithUnderscores name]
+
replacement = Map.lookup name (soChangedSelectors
selectorOptions)
sel' = case replacement of
Just x -> x
@@ -141,6 +147,7 @@
= newEntity $ Entity {
eName = SelectorInstanceName classEntity
selectorEntity factory,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = MethodEntity,
eModule = LocalModule modName
}
@@ -151,6 +158,7 @@
classEntity <- newEntity $ Entity {
eName = CName $ BS.pack clsName,
eHaskellName = getName clsName (nameToUppercase
clsName),
+ eAlternateHaskellNames = [],
eInfo = ClassEntity (fmap (DelayedClassLookup .
BS.pack) mbSuper),
eModule = LocalModule modName
}
@@ -159,6 +167,7 @@
eName = ProtocolAdoptionName
(DelayedClassLookup $ BS.pack clsName)
(DelayedProtocolLookup $ BS.pack
protocol),
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
eModule = LocalModule modName
}
@@ -173,6 +182,7 @@
eName = ProtocolAdoptionName
(DelayedClassLookup $ BS.pack clsName)
(DelayedProtocolLookup $ BS.pack
protocol),
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
eModule = LocalModule modName
}
@@ -187,6 +197,7 @@
newEntity $ Entity {
eName = ProtocolName $ BS.pack protoName,
eHaskellName = getName protoName (nameToUppercase
protoName ++ "Protocol"),
+ eAlternateHaskellNames = [],
eInfo = ProtocolEntity (map
(DelayedProtocolLookup . BS.pack) protocols)
selectors,
eModule = LocalModule modName
@@ -210,6 +221,7 @@
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToUppercase name),
+ eAlternateHaskellNames = [],
eInfo = TypeSynonymEntity (UnconvertedType ct),
eModule = LocalModule modName
}
@@ -220,6 +232,7 @@
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToLowercase name),
+ eAlternateHaskellNames = [],
eInfo = ExternVarEntity (UnconvertedType ct),
eModule = LocalModule modName
}
@@ -230,6 +243,7 @@
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToLowercase name),
+ eAlternateHaskellNames = [],
eInfo = ExternFunEntity (UnconvertedType
(PlainSelector, sel)),
eModule = LocalModule modName
}
@@ -259,6 +273,7 @@
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToUppercase
name),
+ eAlternateHaskellNames = [],
eInfo = EnumEntity True values',
eModule = LocalModule modName
}
@@ -267,12 +282,14 @@
newEntity $ Entity {
eName = Anonymous,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = EnumEntity False values',
eModule = LocalModule modName
}
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToUppercase
name),
+ eAlternateHaskellNames = [],
eInfo = TypeSynonymEntity (UnconvertedType
cTypeInt),
eModule = LocalModule modName
}
@@ -283,6 +300,7 @@
newEntity $ Entity {
eName = Anonymous,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = EnumEntity complete values',
eModule = LocalModule modName
}
@@ -322,6 +340,7 @@
newEntity $ Entity {
eName = Anonymous,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = AdditionalCodeEntity
2
exports
@@ -332,6 +351,7 @@
newEntity $ Entity {
eName = Anonymous,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = AdditionalCodeEntity
9
[]
Modified: trunk/hoc/InterfaceGenerator2/Entities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Entities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Entities.hs Sun Sep 21 13:44:33 2008
@@ -75,6 +75,7 @@
data Entity = Entity {
eName :: Name,
eHaskellName :: ByteString,
+ eAlternateHaskellNames :: [ByteString],
eInfo :: EntityInfo,
eModule :: Module
}
Added: trunk/hoc/InterfaceGenerator2/RenameClashingIdentifiers.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/InterfaceGenerator2/RenameClashingIdentifiers.hs Sun Sep 21
13:44:33 2008
@@ -0,0 +1,148 @@
+module RenameClashingIdentifiers( renameClashingIdentifiers ) where
+
+import Entities
+import qualified Data.Map as Map
+import Data.List( sort, sortBy, groupBy, nub )
+
+import Debug.Trace
+import Data.ByteString.Char8(ByteString)
+import qualified Data.ByteString.Char8 as BS
+
+renameClashingIdentifiers :: EntityPile -> EntityPile
+
+{-data Namespace = SelectorNamespace
+ | UnimportantNamespace
+ deriving (Ord, Eq, Show)
+
+getNamespace (SelectorEntity _) = SelectorNamespace
+getNamespace _ = UnimportantNamespace
+-}
+
+{-
+renameClashingIdentifiers ep
+ = ep { epEntities = Map.fromList $
+ concat $
+ map resolveClash $
+ groupedByModuleAndName }
+ where
+ groupedByModuleAndName
+ = Map.toList $ Map.fromListWith (++) $
+ [ ( (eModule entity, eHaskellName entity{-, getNamespace $
eInfo entity-} ),
+ [(entityID, entity)] )
+ | (entityID, entity) <- Map.toList $ epEntities ep ]
+
+
+ resolveClash ( _, [x] ) = [x]
+ resolveClash ( (mod, name{-, UnimportantNamespace-} ), entities )
+ = entities
+ resolveClash ( (mod, name{-, namespace-} ), entities )
+ | BS.null name = entities
+ resolveClash ( (mod, name{-, namespace-}), entities )
+ = trace (show (mod,name, map (show . eName . snd) entities)) $
+ case possibleCombos of
+ (combo : _)
+ -> trace (show combo) $
+ zipWith renameEntity entities combo
+ where
+ names = map possibleNamesForEntity entities
+
+ possibleNamesFor (LocalID _, e)
+ = eHaskellName e : eAlternateHaskellNames e
+ ++ [ eHaskellName e `BS.append` BS.pack ("_" ++ show
i) | i <- [1..] ]
+ possibleNamesFor (_, e)
+ = [eHaskellName e]
+
+ possibleCombos = filter checkCombo $ nameCombinations names
+
+ checkCombo = all ((==1) . length) . group . sort
+
+ renameEntity (entityID, entity) newName
+ = (entityID, entity { eHaskellName = newName })
+-}
+
+
+renameClashingIdentifiers ep
+ = ep { epEntities = Map.fromList $
+ concatMap handleName $
+ groupedByName }
+ where
+ groupedByName :: [ (ByteString, [ (EntityID, Entity) ]) ]
+ groupedByName
+ = Map.toList $ Map.fromListWith (++) $
+ [ ( eHaskellName entity, [(entityID, entity)] )
+ | (entityID, entity) <- Map.toList $ epEntities ep ]
+
+ handleName :: (ByteString, [ (EntityID, Entity) ]) -> [ (EntityID,
Entity) ]
+ handleName (hName, entities)
+ | BS.null hName
+ = entities
+ | null clashes
+ = entities
+ | otherwise
+ = concat $ zipWith renameEntities (map (map snd)
groupedEntities) $ head possibleCombos
+ where
+ groupedEntities =
+ groupByFst $
+ sortBy (\a b -> compare (fst a) (fst b))
+ [ (originalEntityID e , e) | e <- entities ]
+
+ names = map (possibleNamesFor . head) groupedEntities where
+ possibleNamesFor (LocalEntity _, (_, e))
+ = eHaskellName e : eAlternateHaskellNames e
+ ++ [ eHaskellName e `BS.append` BS.pack ("_" ++
show i) | i <- [1..] ]
+ possibleNamesFor (_, (_, e))
+ = [eHaskellName e]
+
+ possibleCombos = filter checkCombo $ nameCombinations names
+
+ clashes :: [ [Int] ]
+ clashes =
+ filter ( (> 1) . length ) $
+ map nub $
+ map (map snd) $ groupByFst $ sort $
+ --map fst $ (\x -> if BS.unpack hName == "action"
then trace (show x) x else x) $
+ [ (eModule e, index) --, (eid, e))
+ | (index, entities) <- zip [0..] groupedEntities,
+ (_, (eid, e)) <- entities ]
+
+ checkCombo newNames
+ = all checkClash clashes
+ where
+ checkClash clash =
+ trace (show (clash, newNames)) $ nub
toBeTested == toBeTested
+ where toBeTested = extract clash newNames
+
+ extract indices xs = map (xs!!) indices
+ {-extract [] i0 _ = []
+ extract (index : indices) i0 xs
+ = (xs !! (index - i0))
+ : extract indices
+ (index + 1)
+ (drop (index - i0 + 1) xs)-}
+
+ renameEntity (entityID, entity) newName
+ = (entityID, entity { eHaskellName = newName })
+ renameEntities entities newName
+ = map (flip renameEntity newName) entities
+
+ originalEntityID (_, Entity { eInfo = ReexportEntity entityID' })
+ = originalEntityID (entityID', lookupEntity "originalEntityID"
entityID' ep)
+ originalEntityID (entityID, entity)
+ = entityID
+
+ groupByFst :: Eq a => [(a,b)] -> [[(a,b)]]
+ groupByFst = groupBy (\a b -> fst a == fst b)
+
+nameCombinations names = concat $ takeWhile (not . null) $ map (f names)
[0..]
+ where
+ f [] i = return []
+ f [ns] i = do
+ lastName <- take 1 $ drop i ns
+ return [lastName]
+ f (ns:nss) i = do
+ (chosenIndex, chosenName) <- zip [0..i] ns
+ moreChosenNames <- f nss (i - chosenIndex)
+ return (chosenName : moreChosenNames)
+
+
+-- (e1_n1 | e1_n2 | e1_n3) & (e2_n1 | e2_n2) & (!e1_n1 | !e2_n1) & (!e1_n2
| !e2_n2)
\ No newline at end of file
Modified: trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs Sun Sep 21 13:44:33
2008
@@ -37,6 +37,7 @@
= newEntity $ Entity {
eName = SelectorInstanceName cls sel False,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = MethodEntity,
eModule = eModule entity
}
@@ -45,6 +46,7 @@
= newEntity $ Entity {
eName = ProtocolAdoptionName cls proto,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
eModule = eModule entity
}
|
|
From: <cod...@go...> - 2008-09-21 19:46:25
|
Author: wol...@gm...
Date: Sun Sep 21 12:44:49 2008
New Revision: 308
Modified:
trunk/hoc/InterfaceGenerator2/Main.hs
Log:
Revert accidental part of previous commit
Modified: trunk/hoc/InterfaceGenerator2/Main.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Main.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Main.hs Sun Sep 21 12:44:49 2008
@@ -36,7 +36,6 @@
import DependenceGraphs
import ShuffleInstances
import DuplicateEntities
-import RenameClashingIdentifiers
import Output
textInterfaces = False -- Overall 3 times faster with binary
@@ -195,7 +194,7 @@
(zappedEntities, zapMessages) = runMessages $
zapAndReportFailedTypes zapProgress typedEntities
expandedEntities = monitor expandProgress $
expandProtocolRequirements zappedEntities
combinedEntities = monitor combineProgress $
combineDulicateEntities expandedEntities
- finalEntities = renameClashingIdentifiers $
eliminateSubclassInstances eliminateProgress combinedEntities
+ finalEntities = eliminateSubclassInstances eliminateProgress
combinedEntities
do
let packageName = "HOC-" ++ frameworkName
|
|
From: <cod...@go...> - 2008-09-21 19:42:23
|
Author: wol...@gm...
Date: Sun Sep 21 12:42:11 2008
New Revision: 307
Modified:
trunk/hoc/InterfaceGenerator2/Main.hs
trunk/hoc/InterfaceGenerator2/Progress.hs
Log:
Add -q flag to suppress progress output from ifgen
Modified: trunk/hoc/InterfaceGenerator2/Main.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Main.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Main.hs Sun Sep 21 12:42:11 2008
@@ -36,6 +36,7 @@
import DependenceGraphs
import ShuffleInstances
import DuplicateEntities
+import RenameClashingIdentifiers
import Output
textInterfaces = False -- Overall 3 times faster with binary
@@ -119,7 +120,8 @@
oBindingScript :: Maybe String,
oAdditionalCode :: Maybe String,
oShowZapped :: Bool,
- oDumpInitial :: Bool
+ oDumpInitial :: Bool,
+ oQuiet :: Bool
}
processFramework options -- bs frameworkName requiredFrameworks
@@ -131,20 +133,24 @@
putStrLn $ "*** Processing Framework " ++ frameworkName ++ " ***"
- importProgress <- mapM newProgressReporter $
+ let mkProgress n | oQuiet options = return dummyProgressReporter
+ | otherwise = newProgressReporter n
+
+ importProgress <- mapM mkProgress $
map ("Importing " ++) requiredFrameworks
- parseProgress <- newProgressReporter "Parsing Objective-C
header files"
- initialProgress <- newProgressReporter "Building initial
entities"
- resolveProgress <- newProgressReporter "Resolving
cross-references"
- typeProgress <- newProgressReporter "Converting types"
- zapProgress <- newProgressReporter "Zapping unconvertable
entities"
- expandProgress <- newProgressReporter "Filling in additional
instance declarations"
- combineProgress <- newProgressReporter "Combining duplicate
entities"
- eliminateProgress <- newProgressReporter "Eliminating redundant
instances"
- outputProgress <- newProgressReporter "Writing binding modules"
- masterProgress <- newProgressReporter $ "Writing " ++
frameworkName ++ ".hs"
- exportProgress <- newProgressReporter $ "Writing " ++
frameworkName ++ ".pi"
- multiProgress <- openMultiProgress $ parseProgress :
importProgress ++
+ parseProgress <- mkProgress "Parsing Objective-C header files"
+ initialProgress <- mkProgress "Building initial entities"
+ resolveProgress <- mkProgress "Resolving cross-references"
+ typeProgress <- mkProgress "Converting types"
+ zapProgress <- mkProgress "Zapping unconvertable entities"
+ expandProgress <- mkProgress "Filling in additional instance
declarations"
+ combineProgress <- mkProgress "Combining duplicate entities"
+ eliminateProgress <- mkProgress "Eliminating redundant instances"
+ outputProgress <- mkProgress "Writing binding modules"
+ masterProgress <- mkProgress $ "Writing " ++ frameworkName
++ ".hs"
+ exportProgress <- mkProgress $ "Writing " ++ frameworkName
++ ".pi"
+ multiProgress <- if oQuiet options then return dummyMultiProgress
else
+ openMultiProgress $ parseProgress :
importProgress ++
[initialProgress,
resolveProgress,
typeProgress, zapProgress,
expandProgress,
combineProgress,
@@ -189,7 +195,7 @@
(zappedEntities, zapMessages) = runMessages $
zapAndReportFailedTypes zapProgress typedEntities
expandedEntities = monitor expandProgress $
expandProtocolRequirements zappedEntities
combinedEntities = monitor combineProgress $
combineDulicateEntities expandedEntities
- finalEntities = eliminateSubclassInstances eliminateProgress
combinedEntities
+ finalEntities = renameClashingIdentifiers $
eliminateSubclassInstances eliminateProgress combinedEntities
do
let packageName = "HOC-" ++ frameworkName
@@ -268,7 +274,10 @@
"print messages about entities that couldn't be translated",
Option [] ["dump-initial"]
(NoArg (\o -> o { oDumpInitial = True }))
- "dump all entities after parsing"
+ "dump all entities after parsing",
+ Option ['q'] ["quiet"]
+ (NoArg (\o -> o { oQuiet = True }))
+ "don't report progress"
]
main = do
args <- getArgs
@@ -282,7 +291,8 @@
oBindingScript = Nothing,
oAdditionalCode = Nothing,
oShowZapped = False,
- oDumpInitial = False
+ oDumpInitial = False,
+ oQuiet = False
}
options = foldl (flip ($)) options0 optionsF
in
Modified: trunk/hoc/InterfaceGenerator2/Progress.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Progress.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Progress.hs Sun Sep 21 12:42:11 2008
@@ -89,6 +89,8 @@
newtype MultiProgress = MultiProgress (IO ())
+dummyMultiProgress = MultiProgress (return ())
+
openMultiProgress :: [ProgressReporter] -> IO MultiProgress
openMultiProgress reporters'
= do
|
|
From: <cod...@go...> - 2008-09-21 18:37:15
|
Author: wol...@gm...
Date: Sun Sep 21 11:05:56 2008
New Revision: 306
Modified:
trunk/hoc/InterfaceGenerator2/Output.hs
Log:
Add build-type field to generated cabal fields.
Modified: trunk/hoc/InterfaceGenerator2/Output.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Output.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Output.hs Sun Sep 21 11:05:56 2008
@@ -264,6 +264,7 @@
pprCabalFile frameworkName dependencies entities
= text "name:" <+> text "HOC-" <> text frameworkName $+$
text "version: 1.0" $+$
+ text "build-type: Simple" $+$
text "build-depends:" <+>
hsep (punctuate comma $ map text $
["base", "HOC"] ++ map ("HOC-" ++) dependencies) $+$
|
|
From: <cod...@go...> - 2008-09-21 17:58:05
|
Author: wol...@gm...
Date: Sun Sep 21 10:57:47 2008
New Revision: 305
Modified:
trunk/hoc/InterfaceGenerator2/BindingScript.hs
Log:
Hard-code a few standard renamings of selector names that clash with
Haskell keywords
(data, type, class, where), so that they don't need to be specified in the
binding-script.
Modified: trunk/hoc/InterfaceGenerator2/BindingScript.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BindingScript.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BindingScript.hs Sun Sep 21 10:57:47 2008
@@ -44,7 +44,7 @@
bsHiddenFromPrelude = Set.empty,
bsHiddenEnums = Set.empty,
bsTopLevelOptions = SelectorOptions {
- soNameMappings = Map.empty,
+ soNameMappings = defaultNameMappings,
soCovariantSelectors = Set.empty,
soHiddenSelectors = Set.empty,
soChangedSelectors = Map.empty
@@ -52,6 +52,13 @@
bsAdditionalTypes = [],
bsClassSpecificOptions = Map.empty
}
+
+defaultNameMappings = Map.fromList [
+ ("data", "data'"),
+ ("type", "type'"),
+ ("class", "class'"),
+ ("where", "where'")
+ ]
getSelectorOptions :: BindingScript -> String -> SelectorOptions
|
|
From: Wolfgang T. <wth...@us...> - 2007-03-10 19:42:32
|
Update of /cvsroot/hoc/hoc/docs In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv16442/docs Modified Files: Creating_an_Objective-C_Class_in_Haskell.pod Log Message: Update documentation: These days, we have to write InstanceMethod 'foo instead of InstanceMethod foo_info Index: Creating_an_Objective-C_Class_in_Haskell.pod =================================================================== RCS file: /cvsroot/hoc/hoc/docs/Creating_an_Objective-C_Class_in_Haskell.pod,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- Creating_an_Objective-C_Class_in_Haskell.pod 19 May 2004 15:59:28 -0000 1.5 +++ Creating_an_Objective-C_Class_in_Haskell.pod 10 Mar 2007 19:42:29 -0000 1.6 @@ -126,8 +126,8 @@ instance methods, class methods, instance variables, and outlets. The C<ClassMember> data structure is defined as: - data ClassMember = InstanceMethod SelectorInfo - | ClassMethod SelectorInfo + data ClassMember = InstanceMethod Name + | ClassMethod Name | Outlet String TypeQ | InstanceVariable String TypeQ ExpQ @@ -142,10 +142,10 @@ [ Outlet "textView" [t| NSTextView () |] , InstanceVariable "text" [t| Maybe (NSString ()) |] [| Nothing |] - , InstanceMethod info_windowNibName - , InstanceMethod info_writeToFileOfType - , InstanceMethod info_readFromFileOfType - , InstanceMethod info_windowControllerDidLoadNib + , InstanceMethod 'windowNibName + , InstanceMethod 'writeToFileOfType + , InstanceMethod 'readFromFileOfType + , InstanceMethod 'windowControllerDidLoadNib ] =back @@ -168,10 +168,10 @@ $(exportClass "HaskellDocument" "hd_" [ Outlet "textView" [t| NSTextView () |], InstanceVariable "text" [t| Maybe (NSString ()) |] [| Nothing |], - InstanceMethod info_windowNibName, - InstanceMethod info_writeToFileOfType, - InstanceMethod info_readFromFileOfType, - InstanceMethod info_windowControllerDidLoadNib + InstanceMethod 'windowNibName, + InstanceMethod 'writeToFileOfType, + InstanceMethod 'readFromFileOfType, + InstanceMethod 'windowControllerDidLoadNib ]) |
|
From: Wolfgang T. <wth...@us...> - 2007-03-10 19:39:58
|
Update of /cvsroot/hoc/hoc/InterfaceGenerator In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv15806/InterfaceGenerator Removed Files: .gdb_history Log Message: Remove .gdb_history file that shouldn't have been there in the first place --- .gdb_history DELETED --- |
|
From: Wolfgang T. <wth...@us...> - 2007-02-13 17:17:38
|
Update of /cvsroot/hoc/hoc In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv10721 Modified Files: config.mk.in Log Message: Support dynamic linking in the makefiles. Use: make HocBuildDylibs=YES and sudo make install HocBuildDylibs=YES requires a GHC installation with dynamic libraries. Index: config.mk.in =================================================================== RCS file: /cvsroot/hoc/hoc/config.mk.in,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- config.mk.in 27 Sep 2005 11:55:22 -0000 1.6 +++ config.mk.in 13 Feb 2007 17:17:13 -0000 1.7 @@ -32,3 +32,7 @@ cp -R $(dist_FILES) "$(dist_dir)/$(dist_srcdir)" CFLAGS+= -I$(GHC_LIB_PATH)/include + +ifeq "$(HocBuildDylibs)" "YES" +EXTRA_GHCFLAGS += -fPIC -dynamic +endif |
|
From: Wolfgang T. <wth...@us...> - 2007-02-13 17:17:34
|
Update of /cvsroot/hoc/hoc/HOC_cbits In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv10721/HOC_cbits Modified Files: Makefile.in Log Message: Support dynamic linking in the makefiles. Use: make HocBuildDylibs=YES and sudo make install HocBuildDylibs=YES requires a GHC installation with dynamic libraries. Index: Makefile.in =================================================================== RCS file: /cvsroot/hoc/hoc/HOC_cbits/Makefile.in,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- Makefile.in 17 Mar 2006 04:52:34 -0000 1.10 +++ Makefile.in 13 Feb 2007 17:17:13 -0000 1.11 @@ -19,6 +19,7 @@ ../libffi-src/src/powerpc/darwin.S \ ../libffi-src/src/powerpc/darwin_closure.S \ Exceptions.m \ + Statistics.m \ $(NULL) dist_srcdir = HOC_cbits @@ -35,7 +36,15 @@ CFLAGS += -g -I../libffi-src/include -fno-common -DMACOSX ASFLAGS += -I../libffi-src/include -DMACOSX -all: libHOC_cbits.a HOC_cbits.o +ifeq "$(HocBuildDylibs)" "YES" +LIBRARIES=libHOC_cbits.a libHOC_cbits_dyn.dylib +else +LIBRARIES=libHOC_cbits.a HOC_cbits.o +endif + +HOCLIBDIR="$(destdir)"/$(GHC_LIB_PATH)/HOC + +all: $(LIBRARIES) clean: rm -rf libHOC_cbits.a HOC_cbits.o $(OBJS) depend @@ -51,9 +60,13 @@ libHOC_cbits_dyn.dylib: libHOC_cbits.a export MACOSX_DEPLOYMENT_TARGET=10.3 && \ - libtool \ - -dynamic \ + gcc \ + -all_load \ + -dynamiclib \ -undefined dynamic_lookup \ + -lobjc \ + -framework Foundation \ + -single_module \ -o $@ \ $< install_name_tool -id "`pwd`/$@" $@ @@ -65,11 +78,14 @@ cc -MM $(CFLAGS) $(SRCS) > depend install: install-files - ranlib "$(destdir)"/$(GHC_LIB_PATH)/HOC/libHOC_cbits.a + ranlib $(HOCLIBDIR)/libHOC_cbits.a +ifeq "$(HocBuildDylibs)" "YES" + install_name_tool -id $(HOCLIBDIR)/libHOC_cbits_dyn.dylib $(HOCLIBDIR)/libHOC_cbits_dyn.dylib +endif install-files: all - mkdir -p "$(destdir)"/$(GHC_LIB_PATH)/HOC - cp -R libHOC_cbits.a HOC_cbits.o "$(destdir)"/$(GHC_LIB_PATH)/HOC/ + mkdir -p $(HOCLIBDIR) + cp -R $(LIBRARIES) $(HOCLIBDIR) -include depend |
|
From: Wolfgang T. <wth...@us...> - 2007-02-13 17:17:34
|
Update of /cvsroot/hoc/hoc/Tests In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv10721/Tests Modified Files: Makefile Log Message: Support dynamic linking in the makefiles. Use: make HocBuildDylibs=YES and sudo make install HocBuildDylibs=YES requires a GHC installation with dynamic libraries. Index: Makefile =================================================================== RCS file: /cvsroot/hoc/hoc/Tests/Makefile,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- Makefile 1 Nov 2006 15:45:05 -0000 1.3 +++ Makefile 13 Feb 2007 17:17:13 -0000 1.4 @@ -1,6 +1,12 @@ -check: TestFoundation.static +check: static dynamic + +static: TestFoundation.static ./TestFoundation.static +dynamic: TestFoundation.dynamic + ./TestFoundation.dynamic + + build: mkdir -p build/dynamic/imports mkdir -p build/dynamic/objects @@ -18,5 +24,7 @@ -package Foundation --make TestFoundation.hs clean: - -rm *.o *.hi TestFoundation + rm -rf build + rm -f TestFoundation.static + rm -f TestFoundation.dynamic |
|
From: Wolfgang T. <wth...@us...> - 2007-02-13 17:17:21
|
Update of /cvsroot/hoc/hoc/Foundation In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv10721/Foundation Modified Files: Makefile.in Log Message: Support dynamic linking in the makefiles. Use: make HocBuildDylibs=YES and sudo make install HocBuildDylibs=YES requires a GHC installation with dynamic libraries. Index: Makefile.in =================================================================== RCS file: /cvsroot/hoc/hoc/Foundation/Makefile.in,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- Makefile.in 1 Nov 2006 15:45:04 -0000 1.17 +++ Makefile.in 13 Feb 2007 17:17:13 -0000 1.18 @@ -7,7 +7,15 @@ Makefile.in \ $(NULL) -all: libHSFoundation.a HSFoundation.o register-inplace.build-stamp +ifeq "$(HocBuildDylibs)" "YES" +LIBRARIES=libHSFoundation.a libHSFoundation_dyn.dylib +else +LIBRARIES=libHSFoundation.a HSFoundation.o +endif + +FOUNDATIONLIBDIR="$(destdir)"/$(GHC_LIB_PATH)/Foundation + +all: $(LIBRARIES) register-inplace.build-stamp register-inplace.build-stamp: Foundation.conf-inplace [ -f "../inplace.conf" ] || echo '[]' > ../inplace.conf @@ -48,7 +56,8 @@ -package-name Foundation \ -hidir build/imports \ -package-conf ../inplace.conf \ - -fglasgow-exts -fth + -fglasgow-exts -fth\ + $(EXTRA_GHCFLAGS) test ! -r GNUstepBase.hs || \ $(GHC) --make GNUstepBase.hs \ @@ -56,7 +65,8 @@ -odir build/objects \ -hidir build/imports \ -package-conf ../inplace.conf \ - -fglasgow-exts -fth + -fglasgow-exts -fth \ + $(EXTRA_GHCFLAGS) touch $@ HSFoundation.o: ghcmake.build-stamp @@ -67,7 +77,7 @@ libHSFoundation_dyn.dylib: ghcmake.build-stamp export MACOSX_DEPLOYMENT_TARGET=10.3 && find build/objects/ -name \*.o \ - | xargs libtool -dynamic -o $@ -undefined dynamic_lookup + | xargs libtool -dynamic -o $@ -undefined dynamic_lookup -single_module install_name_tool -id "`pwd`/$@" $@ clean: @@ -77,11 +87,15 @@ register-inplace.build-stamp install: install-files - ranlib "$(destdir)"/$(GHC_LIB_PATH)/Foundation/libHSFoundation.a + ranlib $(FOUNDATIONLIBDIR)/libHSFoundation.a +ifeq "$(HocBuildDylibs)" "YES" + install_name_tool -id $(FOUNDATIONLIBDIR)/libHSFoundation_dyn.dylib \ + $(FOUNDATIONLIBDIR)/libHSFoundation_dyn.dylib +endif $(GHC_PKG) update Foundation.conf install-files: all Foundation.conf - mkdir -p "$(destdir)"/$(GHC_LIB_PATH)/Foundation - cp -R libHSFoundation.a HSFoundation.o \ - build/imports "$(destdir)"/$(GHC_LIB_PATH)/Foundation/ + mkdir -p $(FOUNDATIONLIBDIR) + cp -R $(LIBRARIES) \ + build/imports $(FOUNDATIONLIBDIR) |
|
From: Wolfgang T. <wth...@us...> - 2007-02-13 17:17:21
|
Update of /cvsroot/hoc/hoc/AppKit In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv10721/AppKit Modified Files: Makefile.in Log Message: Support dynamic linking in the makefiles. Use: make HocBuildDylibs=YES and sudo make install HocBuildDylibs=YES requires a GHC installation with dynamic libraries. Index: Makefile.in =================================================================== RCS file: /cvsroot/hoc/hoc/AppKit/Makefile.in,v retrieving revision 1.18 retrieving revision 1.19 diff -u -d -r1.18 -r1.19 --- Makefile.in 1 Nov 2006 15:45:04 -0000 1.18 +++ Makefile.in 13 Feb 2007 17:17:13 -0000 1.19 @@ -7,7 +7,15 @@ Makefile.in \ $(NULL) -all: libHSAppKit.a HSAppKit.o register-inplace.build-stamp +ifeq "$(HocBuildDylibs)" "YES" +LIBRARIES=libHSAppKit.a libHSAppKit_dyn.dylib +else +LIBRARIES=libHSAppKit.a HSAppKit.o +endif + +APPKITLIBDIR="$(destdir)"/$(GHC_LIB_PATH)/AppKit + +all: $(LIBRARIES) register-inplace.build-stamp register-inplace.build-stamp: AppKit.conf-inplace [ -f "../inplace.conf" ] || echo '[]' > ../inplace.conf @@ -49,21 +57,24 @@ -odir build/objects \ -hidir build/imports \ -package-conf ../inplace.conf \ - -fglasgow-exts -fth + -fglasgow-exts -fth \ + $(EXTRA_GHCFLAGS) test ! -r GNUstepGUI.hs || \ $(GHC) --make GNUstepGUI.hs \ -package-name AppKit \ -odir build/objects \ -hidir build/imports \ -package-conf ../inplace.conf \ - -fglasgow-exts -fth + -fglasgow-exts -fth \ + $(EXTRA_GHCFLAGS) $(GHC) -c Cocoa.hs \ -package-name AppKit \ -ibuild/imports \ -o build/objects/Cocoa.o \ -ohi build/imports/Cocoa.hi \ -package-conf ../inplace.conf \ - -fglasgow-exts -fth + -fglasgow-exts -fth \ + $(EXTRA_GHCFLAGS) touch $@ HSAppKit.o: ghcmake.build-stamp @@ -74,7 +85,7 @@ libHSAppKit_dyn.dylib: ghcmake.build-stamp export MACOSX_DEPLOYMENT_TARGET=10.3 && find build/objects/ -name \*.o \ - | xargs libtool -dynamic -o $@ -undefined dynamic_lookup + | xargs libtool -dynamic -o $@ -undefined dynamic_lookup -single_module install_name_tool -id "`pwd`/$@" $@ clean: @@ -84,11 +95,15 @@ register-inplace.build-stamp install: install-files - ranlib "$(destdir)"/$(GHC_LIB_PATH)/AppKit/libHSAppKit.a + ranlib $(APPKITLIBDIR)/libHSAppKit.a +ifeq "$(HocBuildDylibs)" "YES" + install_name_tool -id $(APPKITLIBDIR)/libHSAppKit_dyn.dylib \ + $(APPKITLIBDIR)/libHSAppKit_dyn.dylib +endif ghc-pkg --update-package --input-file=AppKit.conf install-files: all AppKit.conf - mkdir -p "$(destdir)"/$(GHC_LIB_PATH)/AppKit - cp -R libHSAppKit.a HSAppKit.o build/imports \ - "$(destdir)"/$(GHC_LIB_PATH)/AppKit/ + mkdir -p $(APPKITLIBDIR) + cp -R $(LIBRARIES) build/imports \ + $(APPKITLIBDIR) |
|
From: Wolfgang T. <wth...@us...> - 2007-02-13 17:17:21
|
Update of /cvsroot/hoc/hoc/HOC In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv10721/HOC Modified Files: Makefile.in Log Message: Support dynamic linking in the makefiles. Use: make HocBuildDylibs=YES and sudo make install HocBuildDylibs=YES requires a GHC installation with dynamic libraries. Index: Makefile.in =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/Makefile.in,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- Makefile.in 1 Nov 2006 15:45:04 -0000 1.17 +++ Makefile.in 13 Feb 2007 17:17:13 -0000 1.18 @@ -11,7 +11,15 @@ Makefile.in \ $(NULL) -all: libHOC.a HOC.o ../inplace.conf +ifeq "$(HocBuildDylibs)" "YES" +LIBRARIES=libHOC.a libHOC_dyn.dylib +else +LIBRARIES=libHOC.a HOC.o +endif + +HOCLIBDIR="$(destdir)"/$(GHC_LIB_PATH)/HOC + +all: $(LIBRARIES) ../inplace.conf ../inplace.conf: HOC.conf-inplace [ -f "$@" ] || echo '[]' > $@ @@ -31,11 +39,12 @@ libHOC.a: ghcmake.build-stamp find build/objects/ -name \*.o | xargs $(MAKE_STATIC_LIB) libHOC.a -libHOC_dyn.dylib: ghcmake +libHOC_dyn.dylib: ghcmake.build-stamp export MACOSX_DEPLOYMENT_TARGET=10.3 && find build/objects/ -name \*.o \ | xargs libtool \ -dynamic \ -undefined dynamic_lookup \ + -single_module \ -o $@ install_name_tool -id "`pwd`/$@" $@ @@ -44,6 +53,11 @@ ghcmake: ghcmake.build-stamp +ifeq "$(HocBuildDylibs)" "YES" +CBITS=-L../HOC_cbits -lHOC_cbits_dyn +else +CBITS=../HOC_cbits/HOC_cbits.o +endif ghcmake.build-stamp: mkdir -p build/objects @@ -52,13 +66,15 @@ -O -fasm \ -odir build/objects -hidir build/imports \ -fglasgow-exts -fth \ - ../HOC_cbits/HOC_cbits.o \ + -lobjc \ + $(CBITS) \ -I../HOC_cbits \ -I../libffi-src/build/include \ -package-name HOC \ $(FOUNDATION_INCLUDES) \ $(FOUNDATION_LIBS) \ - $(DEFINES) + $(DEFINES) \ + $(EXTRA_GHCFLAGS) touch $@ clean: @@ -67,10 +83,13 @@ ghcmake.build-stamp install: install-files - ranlib "$(destdir)"/$(GHC_LIB_PATH)/HOC/libHOC.a + ranlib $(HOCLIBDIR)/libHOC.a +ifeq "$(HocBuildDylibs)" "YES" + install_name_tool -id $(HOCLIBDIR)/libHOC_dyn.dylib $(HOCLIBDIR)/libHOC_dyn.dylib +endif $(GHC_PKG) update HOC.conf install-files: all HOC.conf - mkdir -p "$(destdir)"/$(GHC_LIB_PATH)/HOC - cp -R libHOC.a HOC.o build/imports \ - "$(destdir)"/$(GHC_LIB_PATH)/HOC/ + mkdir -p $(HOCLIBDIR) + cp -R $(LIBRARIES) build/imports \ + $(HOCLIBDIR) |
|
From: Wolfgang T. <wth...@us...> - 2007-02-13 17:11:21
|
Update of /cvsroot/hoc/hoc/HOC_cbits In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv6881/HOC_cbits Modified Files: NewClass.m Added Files: Statistics.h Statistics.m Log Message: a) Utilities cleanup: remove #* (send message and release result) add #. (get instance variable) add declareMarshalledObjectType b) sending init messages to super is now supported c) can now implement methods that return a retained object (like init) --- NEW FILE: Statistics.h --- #include <objc/objc.h> enum { kHOCAboutToEnterHaskell = 0, kHOCEnteredHaskell, kHOCImportedArguments, kHOCAboutToExportResult, kHOCAboutToLeaveHaskell, kHOCLeftHaskell }; void recordHOCEvent(int what, void ** args); --- NEW FILE: Statistics.m --- #import "Statistics.h" #include <stdint.h> #include <stdio.h> //#define DO_TIMINGS #ifdef DO_TIMINGS #if !GNUSTEP #include <mach/mach.h> #include <mach/mach_time.h> inline uint64_t abstime() { return mach_absolute_time(); } static double tonano(uint64_t x) { uint64_t time = mach_absolute_time(); static mach_timebase_info_data_t sTimebaseInfo; if ( sTimebaseInfo.denom == 0 ) { mach_timebase_info(&sTimebaseInfo); } return (double)x * sTimebaseInfo.numer / sTimebaseInfo.denom; } #endif #endif static double enteringTime = 0; static double importTime = 0; const double weight = 0.01; void recordHOCEvent(int what, void ** args) { id obj; SEL sel; obj = *(id*) args[0]; sel = *(SEL*) args[1]; // printf("recordHOCEvent %d\n", what); #ifdef DO_TIMINGS static uint64_t saved; double time; switch(what) { case kHOCAboutToEnterHaskell: saved = abstime(); break; case kHOCEnteredHaskell: time = tonano(abstime() - saved); // if(time > 100000) // printf("Took a long time to enter: %g\n", time); if(enteringTime != 0) enteringTime = (1-weight) * enteringTime + weight * time; else enteringTime = time; saved = abstime(); break; case kHOCImportedArguments: time = tonano(abstime() - saved); // if(time > 100000) // printf("Took a long time to import: %g\n", time); if(importTime != 0) importTime = (1-weight) * importTime + weight * time; else importTime = time; break; } #endif } Index: NewClass.m =================================================================== RCS file: /cvsroot/hoc/hoc/HOC_cbits/NewClass.m,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- NewClass.m 6 Apr 2004 12:36:13 -0000 1.3 +++ NewClass.m 13 Feb 2007 17:11:04 -0000 1.4 @@ -2,6 +2,7 @@ #include <Foundation/NSException.h> #include <assert.h> #include "NewClass.h" +#include "Statistics.h" #ifdef GNUSTEP #define isa class_pointer @@ -101,7 +102,9 @@ static void objcIMP(ffi_cif *cif, void * ret, void **args, void *userData) { + recordHOCEvent(kHOCAboutToEnterHaskell, args); NSException *e = (*(haskellIMP)userData)(cif, ret, args); + recordHOCEvent(kHOCLeftHaskell, args); if(e != nil) [e raise]; } |
|
From: Wolfgang T. <wth...@us...> - 2007-02-13 17:11:21
|
Update of /cvsroot/hoc/hoc/HOC In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv6881/HOC Modified Files: HOC.hs Log Message: a) Utilities cleanup: remove #* (send message and release result) add #. (get instance variable) add declareMarshalledObjectType b) sending init messages to super is now supported c) can now implement methods that return a retained object (like init) Index: HOC.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC.hs,v retrieving revision 1.14 retrieving revision 1.15 diff -u -d -r1.14 -r1.15 --- HOC.hs 20 Mar 2006 06:32:16 -0000 1.14 +++ HOC.hs 13 Feb 2007 17:11:04 -0000 1.15 @@ -5,8 +5,7 @@ Object(..), Class, ClassAndObject, - ( # ), ( #* ), - ObjCArgument(..), + ( # ), ( #. ), withExportedArray, castObject, declareClass, @@ -47,6 +46,9 @@ sel, + ObjCArgument(..), + declareMarshalledObjectType, + -- debugging & statistics: objectMapStatistics |
|
From: Wolfgang T. <wth...@us...> - 2007-02-13 17:11:21
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv6881/HOC/HOC Modified Files: Arguments.hs DeclareSelector.hs ExportClass.hs ID.hs Invocation.hs NewlyAllocated.hs SelectorMarshaller.hs Super.hs Utilities.hs Log Message: a) Utilities cleanup: remove #* (send message and release result) add #. (get instance variable) add declareMarshalledObjectType b) sending init messages to super is now supported c) can now implement methods that return a retained object (like init) Index: ID.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/ID.hs,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- ID.hs 27 Jul 2005 02:36:09 -0000 1.9 +++ ID.hs 13 Feb 2007 17:11:04 -0000 1.10 @@ -136,6 +136,12 @@ return arg exportArgument Nil = return nullPtr + exportArgumentRetained (ID thing@(HSO arg _)) = do + retainObject arg + evaluate thing -- make sure the HSO has been alive until now + return arg + exportArgumentRetained Nil = return nullPtr + importArgument = importArgument' False objCTypeString _ = "@" Index: ExportClass.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/ExportClass.hs,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- ExportClass.hs 20 Mar 2006 06:25:26 -0000 1.10 +++ ExportClass.hs 13 Feb 2007 17:11:04 -0000 1.11 @@ -174,6 +174,7 @@ exportMethod' isClassMethod objCMethodList num methodBody nArgs isUnit impTypeName selExpr cifExpr + retainedExpr where methodBody = varE $ mkName $ prefix ++ nameBase selName @@ -186,6 +187,7 @@ selExpr = [| selectorInfoSel $(varE $ infoName) |] cifExpr = [| selectorInfoCif $(varE $ infoName) |] + retainedExpr = [| selectorInfoResultRetained $(varE $ infoName) |] exportMethod isClassMethod objCMethodList (GetterMethod ivarName, num) = exportMethod' isClassMethod objCMethodList num @@ -193,6 +195,7 @@ 0 False (''GetVarImpType) [| getSelectorForName ivarName |] [| getVarCif |] + [| False |] exportMethod isClassMethod objCMethodList (SetterMethod ivarName, num) = exportMethod' isClassMethod objCMethodList num @@ -200,6 +203,7 @@ 1 True (''SetVarImpType) [| getSelectorForName setterName |] [| setVarCif |] + [| False |] where setterName = setterNameFor ivarName @@ -208,7 +212,7 @@ exportMethod' isClassMethod objCMethodList num methodBody - nArgs isUnit impTypeName selExpr cifExpr = + nArgs isUnit impTypeName selExpr cifExpr retainedExpr = [| setMethodInList $(objCMethodList) num @@ -218,24 +222,29 @@ ($(lamE (map (varP.mkName) ["cif","ret","args"]) marshal)) |] where - marshal = [| exceptionHaskellToObjC $(marshal') |] + marshal = [| do recordHOCEvent kHOCEnteredHaskell $(varE $ mkName "args") + exc <- exceptionHaskellToObjC $(marshal') + recordHOCEvent kHOCAboutToLeaveHaskell $(varE $ mkName "args") + return exc + |] marshal' = doE $ getArg ("self",0) : map getArg (zip arguments [2..]) - ++ invokeAndReturn + ++ [ + noBindS [| recordHOCEvent kHOCImportedArguments $(varE $ mkName "args") |], + noBindS invokeAndReturn + ] arguments = [ "arg" ++ show i | i <- [1..nArgs] ] invokeAndReturn | isUnit = - [noBindS typedBodyWithArgs] + typedBodyWithArgs | otherwise = - [ - bindS (varP $ mkName "result") typedBodyWithArgs, - noBindS [| setMarshalledRetval - $(varE $ mkName "ret") - $(varE $ mkName "result") |] - ] + [| do result <- $(typedBodyWithArgs) + recordHOCEvent kHOCAboutToExportResult $(varE $ mkName "args") + setMarshalledRetval $(retainedExpr) $(varE $ mkName "ret") result + |] typedBodyWithArgs = foldl1 appE (typed methodBody : map (varE.mkName)(arguments ++ ["self"])) Index: Super.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Super.hs,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- Super.hs 27 Jul 2005 02:36:09 -0000 1.2 +++ Super.hs 13 Feb 2007 17:11:04 -0000 1.3 @@ -1,5 +1,6 @@ +{-# OPTIONS -fallow-undecidable-instances #-} module HOC.Super( - SuperClass, SuperTarget, super + SuperClass, SuperTarget, Super(super), withExportedSuper ) where import HOC.Base @@ -20,29 +21,34 @@ data SuperTarget a = SuperTarget a -super :: (Object sub, Object super, SuperClass sub super) - => sub -> SuperTarget super +class Super sub super | sub -> super where + super :: sub -> super --- pokeSuper objcSuper obj cls = pokeByteOff objcSuper 0 obj >> pokeByteOff objcSuper (sizeOf obj) cls +withExportedSuper p action = + getSuperClassForObject p >>= \cls -> + allocaBytes (sizeOf p + sizeOf cls) $ \sptr -> + pokeSuper sptr p cls >> action sptr + instance MessageTarget a => ObjCArgument (SuperTarget a) (Ptr ObjCObject) where withExportedArgument (SuperTarget obj) action = withExportedArgument obj $ \p -> - getSuperClassForObject p >>= \cls -> - allocaBytes (sizeOf p + sizeOf cls) $ \sptr -> - pokeSuper sptr p cls >> action sptr + withExportedSuper p action exportArgument _ = fail "HOC.Super: exportArgument" importArgument _ = fail "HOC.Super: importArgument" objCTypeString _ = "@" -- well, close enough. -super obj = SuperTarget (fromID $ toID obj) +instance (Object (ID sub), Object super, SuperClass (ID sub) super) + => Super (ID sub) (SuperTarget super) where + super obj = SuperTarget (fromID $ toID obj) getSuperClassForObject obj = do cls <- peekByteOff obj 0 :: IO (Ptr (Ptr ())) peekElemOff cls 1 Index: Arguments.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Arguments.hs,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- Arguments.hs 17 Mar 2006 04:57:37 -0000 1.6 +++ Arguments.hs 13 Feb 2007 17:11:04 -0000 1.7 @@ -15,11 +15,14 @@ class (Storable b, FFITypeable b) => ObjCArgument a b | a -> b where withExportedArgument :: a -> (b -> IO c) -> IO c exportArgument :: a -> IO b + exportArgumentRetained :: a -> IO b importArgument :: b -> IO a objCTypeString :: a -> String withExportedArgument arg action = exportArgument arg >>= action + + exportArgumentRetained = exportArgument {- For types that are Storable & FFITypeable, define Index: SelectorMarshaller.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/SelectorMarshaller.hs,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- SelectorMarshaller.hs 26 Jul 2005 05:23:48 -0000 1.10 +++ SelectorMarshaller.hs 13 Feb 2007 17:11:04 -0000 1.11 @@ -1,6 +1,7 @@ module HOC.SelectorMarshaller( SelectorInfo(..), mkSelectorInfo, + mkSelectorInfoRetained, makeMarshaller, makeMarshallers, marshallerName @@ -25,17 +26,18 @@ selectorInfoObjCName :: String, selectorInfoHaskellName :: String, selectorInfoCif :: !FFICif, - selectorInfoSel :: !SEL + selectorInfoSel :: !SEL, + selectorInfoResultRetained :: !Bool } {-# NOINLINE mkSelectorInfo #-} mkSelectorInfo objCName hsName cif - = SelectorInfo objCName hsName cif (getSelectorForName objCName) + = SelectorInfo objCName hsName cif (getSelectorForName objCName) False {-# NOINLINE mkSelectorInfo# #-} mkSelectorInfo# objCName# hsName# cif -- NOTE: Don't call mkSelectorInfo here, the rule would apply! - = SelectorInfo objCName hsName cif (getSelectorForName objCName) + = SelectorInfo objCName hsName cif (getSelectorForName objCName) False where objCName = unpackCString# objCName# hsName = unpackCString# hsName# @@ -46,6 +48,25 @@ = mkSelectorInfo# s1 s2 cif #-} +{-# NOINLINE mkSelectorInfoRetained #-} +mkSelectorInfoRetained objCName hsName cif + = SelectorInfo objCName hsName cif (getSelectorForName objCName) True + +{-# NOINLINE mkSelectorInfoRetained# #-} +mkSelectorInfoRetained# objCName# hsName# cif + -- NOTE: Don't call mkSelectorInfo here, the rule would apply! + = SelectorInfo objCName hsName cif (getSelectorForName objCName) True + where + objCName = unpackCString# objCName# + hsName = unpackCString# hsName# + +{-# RULES +"litstr" forall s1 s2 cif. + mkSelectorInfoRetained (unpackCString# s1) (unpackCString# s2) cif + = mkSelectorInfoRetained# s1 s2 cif + #-} + + makeMarshaller maybeInfoName haskellName nArgs isUnit isPure isRetained = funD haskellName [ clause (map varP $ infoArgument ++ map mkName arguments Index: DeclareSelector.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- DeclareSelector.hs 1 Nov 2006 15:45:04 -0000 1.13 +++ DeclareSelector.hs 13 Feb 2007 17:11:04 -0000 1.14 @@ -164,14 +164,17 @@ makeImpType ty = replaceResult ( - (ArrowT `AppT` VarT (mkName "target")) + (ArrowT `AppT` fromMaybe (VarT $ mkName "target") target') `AppT` covariantResult ) ty' where ty' = simplifyType ty - (_retained, _needInstance, _target', covariantResult) = + (_retained, _needInstance, target', covariantResult) = doctorCovariant $ resultType ty' - + + selInfoMaker | resultRetained = [| mkSelectorInfoRetained |] + | otherwise = [| mkSelectorInfo |] + sequence $ [ -- $(selectorName) = getSelectorForName "name" @@ -183,7 +186,7 @@ in valD (varP $ mkName $ infoName) (normalB [| let n = $(stringE name) - in mkSelectorInfo n + in $(selInfoMaker) n $(if haskellName == name then [|n|] else stringE haskellName) Index: Utilities.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Utilities.hs,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -d -r1.1.1.1 -r1.2 --- Utilities.hs 27 Oct 2003 16:48:10 -0000 1.1.1.1 +++ Utilities.hs 13 Feb 2007 17:11:04 -0000 1.2 @@ -2,6 +2,43 @@ import HOC.Base import HOC.Arguments +import HOC.ID +import HOC.TH +import HOC.ExportClass +import Foreign.Ptr x # f = f x -obj #* msg = obj # msg >>= \newObj -> withExportedArgument newObj releaseObject >> return newObj + +x #. v = x # getIVar v + +declareMarshalledObjectType ty + = do + (context, ty') <- splitTy ty + argInst <- instanceD context (conT ''ObjCArgument + `appT` ty' `appT` [t| Ptr ObjCObject |]) + `whereQ` valDs [ + ('withExportedArgument, [| withExportedArgument . toID |]), + ('exportArgument, [| exportArgument . toID |]), + ('exportArgumentRetained, [| exportArgumentRetained . toID |]), + ('importArgument, [| fmap fromID . importArgument |]), + ('objCTypeString, [| objCTypeString . toID |]) + ] + msgTarget <- instanceD context (conT ''MessageTarget + `appT` ty') + `whereQ` valDs [ + ('isNil, [| \_ -> False |]), + ('sendMessageWithRetval, [| sendMessageWithRetval . toID |]), + ('sendMessageWithoutRetval, [| sendMessageWithoutRetval . toID |]) + ] + return [argInst, msgTarget] + where + valDs decls + = sequence [ + do e <- b ; return (ValD (VarP n) (NormalB e) []) + | (n, b) <- decls + ] + + splitTy ty = do t <- ty + return $ case t of + (ForallT ns context t') -> (return context, return t') + other -> (cxt [], ty) \ No newline at end of file Index: NewlyAllocated.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/NewlyAllocated.hs,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- NewlyAllocated.hs 27 Jul 2005 02:36:09 -0000 1.4 +++ NewlyAllocated.hs 13 Feb 2007 17:11:04 -0000 1.5 @@ -1,3 +1,4 @@ +{-# OPTIONS -fallow-undecidable-instances #-} module HOC.NewlyAllocated where {- @@ -15,15 +16,24 @@ import HOC.Arguments ( ObjCArgument(..) ) import HOC.ID ( Object(..), MessageTarget(..) ) import HOC.MsgSend +import HOC.Super import Foreign.Ptr ( Ptr, nullPtr ) import System.IO.Unsafe ( unsafePerformIO ) -newtype NewlyAllocated a = NewlyAllocated (Ptr ObjCObject) + +data NewlyAllocated a + = NewlyAllocated (Ptr ObjCObject) + | NewSuper (Ptr ObjCObject) instance ObjCArgument (NewlyAllocated a) (Ptr ObjCObject) where withExportedArgument (NewlyAllocated p) action = action p + withExportedArgument (NewSuper p) action = + withExportedSuper p action + exportArgument (NewlyAllocated p) = return p + exportArgument (NewSuper p) = fail "HOC.NewlyAllocated.NewSuper: exportArgument" + importArgument p = return (NewlyAllocated p) objCTypeString _ = "@" @@ -35,6 +45,13 @@ instance MessageTarget (NewlyAllocated a) where isNil (NewlyAllocated p) = p == nullPtr + isNil (NewSuper p) = p == nullPtr - sendMessageWithRetval _ = objSendMessageWithRetval - sendMessageWithoutRetval _ = objSendMessageWithoutRetval + sendMessageWithRetval (NewlyAllocated _) = objSendMessageWithRetval + sendMessageWithRetval (NewSuper _) = superSendMessageWithRetval + sendMessageWithoutRetval (NewlyAllocated _) = objSendMessageWithoutRetval + sendMessageWithoutRetval (NewSuper _) = superSendMessageWithoutRetval + +instance SuperClass sub super + => Super (NewlyAllocated sub) (NewlyAllocated super) where + super (NewlyAllocated x) = NewSuper x Index: Invocation.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Invocation.hs,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- Invocation.hs 27 Sep 2005 11:55:22 -0000 1.2 +++ Invocation.hs 13 Feb 2007 17:11:04 -0000 1.3 @@ -1,6 +1,7 @@ module HOC.Invocation where import Foreign +import Foreign.C ( CInt ) import Control.Monad ( when ) import HOC.Base @@ -42,12 +43,23 @@ >> peek retptr >>= importArgument -setMarshalledRetval :: ObjCArgument a b => Ptr () -> a -> IO () -setMarshalledRetval ptr val = - exportArgument val >>= poke (castPtr ptr) +setMarshalledRetval :: ObjCArgument a b => Bool -> Ptr () -> a -> IO () +setMarshalledRetval retained ptr val = + (if retained then exportArgumentRetained else exportArgument) val + >>= poke (castPtr ptr) getMarshalledArgument :: ObjCArgument a b => Ptr (Ptr ()) -> Int -> IO a getMarshalledArgument args idx = do p <- peekElemOff args idx arg <- peek (castPtr p) importArgument arg + + +foreign import ccall unsafe recordHOCEvent :: CInt -> Ptr (Ptr ()) -> IO () + +kHOCEnteredHaskell = 1 :: CInt +kHOCImportedArguments = 2 :: CInt +kHOCAboutToExportResult = 3 :: CInt +kHOCAboutToLeaveHaskell = 4 :: CInt + + |
