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...> - 2009-08-11 18:58:32
|
Revision: 391 Author: jam...@us... Date: Tue Aug 11 11:50:17 2009 Log: (objc2 branch) pulled just-committed cabal build fix from trunk http://code.google.com/p/hoc/source/detail?r=391 Modified: / /branches/objc2/hoc /branches/objc2/hoc/HOC.cabal /branches/objc2/hoc/Setup.hs ======================================= --- /branches/objc2/hoc/HOC.cabal Tue Aug 11 11:50:04 2009 +++ /branches/objc2/hoc/HOC.cabal Tue Aug 11 11:50:17 2009 @@ -64,7 +64,16 @@ hs-source-dirs: HOC extra-libraries: objc, ffi + + -- This is a hack. + -- Setup.hs contains code to build HOC_cbits.o from the + -- objective-c sources, as well as a matching hack to prevent + -- Cabal from invoking "ghc -c" on this file. Cabal will then + -- include HOC_cbits.o on the linker command line, which is the + -- whole point of this exercise. c-sources: HOC_cbits.o + + if os(darwin) include-dirs: /usr/include/ffi frameworks: Foundation ======================================= --- /branches/objc2/hoc/Setup.hs Wed Dec 10 14:10:22 2008 +++ /branches/objc2/hoc/Setup.hs Tue Aug 11 11:50:17 2009 @@ -5,6 +5,7 @@ import Distribution.Simple.PreProcess import Distribution.Simple.Configure import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program import System.Cmd( system ) import System.Exit( ExitCode(..) ) import System.Environment( getEnv ) @@ -99,6 +100,13 @@ extraFlags <- buildCBits (libBuildInfo libInfo) + -- add compiler flags required by C parts of HOC; + -- + -- HACK #1: + -- This passes the HOC_cbits.o object file on the + -- as a compiler flag so that template haskell can link + -- compile-time code. + let hooked_pd = pd { library = Just $ libInfo { libBuildInfo = addCompilerFlags extraFlags @@ -109,7 +117,42 @@ (executables pd) } - build hooked_pd lbi buildFlags knownSuffixHandlers + -- HACK #2: + -- HOC_cbits.o (built by buildCBits below) is specified in c-sources + -- for the library. Cabal reacts to this by invoking ghc -c HOC_cbits.o, + -- which ghc doesn't like. So, instead of calling ghc directly, we call + -- a short auto-generated shell script that does nothing in this case, + -- and calls the real ghc in all other cases. + -- After having "compiled" HOC_cbits.o in this way, Cabal will link + -- HOC_cbits.o as part of the library, which is what we want. + + let Just pr = lookupKnownProgram "ghc" (withPrograms lbi) + Just conf = lookupProgram pr (withPrograms lbi) + + ghcLocation = programLocation conf + + let fakeGHC = "./dist/build/fake-ghc.sh" + + writeFile fakeGHC $ unlines [ + "#!/bin/sh -e", + "case \"$*\" in", + " *HOC_cbits.o) true;;", + " *) \"" ++ locationPath ghcLocation ++ "\" \"$@\";;", + "esac" + ] + system $ "chmod +x " ++ fakeGHC + + let conf' = conf { programLocation = UserSpecified fakeGHC } + + progs' = updateProgram conf' (withPrograms lbi) + + let lbi' = lbi { + withPrograms = progs' + } + + -- call the default with our modified package description and + -- local build info + build hooked_pd lbi' buildFlags knownSuffixHandlers -- |Build HOC_cbits.o using the flags specified in the configuration -- stage, and return a list of flags to add to support usage of |
|
From: <cod...@go...> - 2009-08-11 18:54:29
|
Revision: 390 Author: jam...@us... Date: Tue Aug 11 11:50:04 2009 Log: (objc2 branch) merged changes from trunk http://code.google.com/p/hoc/source/detail?r=390 Modified: / /branches/objc2/hoc /branches/objc2/hoc/Bindings/AdditionalCode/Foundation/NSException.hs /branches/objc2/hoc/HOC/HOC/Exception.hs /branches/objc2/hoc/HOC.cabal /branches/objc2/hoc/InterfaceGenerator2/Output.hs /branches/objc2/hoc/Tests/MiniFoundation.hs /branches/objc2/hoc/Tests/TestFoundation.hs ======================================= --- /branches/objc2/hoc/Bindings/AdditionalCode/Foundation/NSException.hs Tue Mar 7 22:53:38 2006 +++ /branches/objc2/hoc/Bindings/AdditionalCode/Foundation/NSException.hs Tue Aug 11 11:50:04 2009 @@ -1,10 +1,9 @@ --X catchNS -import Control.Exception ( catchDyn ) -import HOC.Exception ( WrappedNSException(..) ) +import HOC.Exception ( WrappedNSException(..), catchWrappedNSException ) -- CUT HERE catchNS :: IO a -> (NSException () -> IO a) -> IO a catchNS action handler - = action `catchDyn` \(WrappedNSException exc) -> handler (castObject exc) + = action `catchWrappedNSException` \(WrappedNSException exc) -> handler (castObject exc) ======================================= --- /branches/objc2/hoc/HOC/HOC/Exception.hs Fri Jan 9 17:57:45 2009 +++ /branches/objc2/hoc/HOC/HOC/Exception.hs Tue Aug 11 11:50:04 2009 @@ -1,11 +1,12 @@ -{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, + ScopedTypeVariables, CPP #-} module HOC.Exception where import Data.Typeable import Foreign import Foreign.C.String ( CString, withCString ) import Prelude hiding ( catch ) -import Control.Exception ( Exception, evaluate, throwIO, throwDyn, catchDyn, catch ) +import Control.Exception import HOC.Base import HOC.Arguments @@ -14,11 +15,53 @@ data WrappedNSException = WrappedNSException (ID ()) deriving Typeable - -foreign import ccall unsafe wrapHaskellException :: CString -> StablePtr Exception -> IO (Ptr ObjCObject) -foreign import ccall unsafe unwrapHaskellException :: Ptr ObjCObject -> IO (StablePtr Exception) - -exceptionObjCToHaskell :: Ptr ObjCObject -> IO a +exceptionObjCToHaskell :: Ptr ObjCObject -> IO a + +#ifdef BASE4 + +foreign import ccall unsafe wrapHaskellException + :: CString -> StablePtr SomeException -> IO (Ptr ObjCObject) +foreign import ccall unsafe unwrapHaskellException + :: Ptr ObjCObject -> IO (StablePtr SomeException) + +-- get the exception pointer figure out if it is a NSException +-- or a haskell exception and throw it. +exceptionObjCToHaskell exception = do + sptr <- unwrapHaskellException exception + if (castStablePtrToPtr sptr == nullPtr) + then do + exc <- importArgument exception + throwIO $ WrappedNSException exc + else do + exc <- deRefStablePtr sptr + throwIO exc + +exceptionHaskellToObjC :: IO a -> IO (Ptr ObjCObject) + +exceptionHaskellToObjC action = + (action >> return nullPtr) + `catches` [ + Handler $ \(WrappedNSException exc) -> exportArgument exc, + Handler $ \(exc :: SomeException) -> withCString (show exc) $ + \cstr -> newStablePtr exc >>= wrapHaskellException cstr + ] + +instance Exception WrappedNSException where + toException = SomeException + fromException (SomeException ex) = cast ex + +instance Show WrappedNSException where + show (WrappedNSException ex) = "<<NSException>>" + +catchWrappedNSException :: IO a -> (WrappedNSException -> IO a) -> IO a +catchWrappedNSException = catch + +#else + +foreign import ccall unsafe wrapHaskellException + :: CString -> StablePtr Exception -> IO (Ptr ObjCObject) +foreign import ccall unsafe unwrapHaskellException + :: Ptr ObjCObject -> IO (StablePtr Exception) -- get the exception pointer figure out if it is a NSException -- or a haskell exception and throw it. @@ -40,3 +83,8 @@ (\(WrappedNSException exc) -> exportArgument exc) `catch` (\exc -> withCString (show exc) $ \cstr -> newStablePtr exc >>= wrapHaskellException cstr) + +catchWrappedNSException :: IO a -> (WrappedNSException -> IO a) -> IO a +catchWrappedNSException = catchDyn + +#endif ======================================= --- /branches/objc2/hoc/HOC.cabal Fri Jan 9 17:57:45 2009 +++ /branches/objc2/hoc/HOC.cabal Tue Aug 11 11:50:04 2009 @@ -17,8 +17,15 @@ Flag ObjC2 description: build for Objective-C 2.0 +Flag base4 + Library - build-depends: base < 4, template-haskell, unix + build-depends: template-haskell, unix + if flag(base4) + build-depends: base >= 4, syb + cpp-options: -DBASE4 + else + build-depends: base < 4 exposed-modules: HOC, @@ -87,7 +94,12 @@ cpp-options: -DTEST - build-depends: HUnit + build-depends: HUnit, template-haskell, unix + if flag(base4) + build-depends: base >= 4, syb + cpp-options: -DBASE4 + else + build-depends: base < 4 if !flag(Tests) buildable: False ======================================= --- /branches/objc2/hoc/InterfaceGenerator2/Output.hs Tue Aug 11 11:49:43 2009 +++ /branches/objc2/hoc/InterfaceGenerator2/Output.hs Tue Aug 11 11:50:04 2009 @@ -293,13 +293,21 @@ = 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) $+$ --- text "" $+$ - text "exposed-modules:" <+> sep (punctuate comma $ - map textBS $ BS.pack frameworkName : modules) $+$ - text "frameworks:" <+> text frameworkName + text "Flag base4" $+$ + text "Library" $+$ nest 4 ( + text "if flag(base4)" $+$ nest 4 ( + text "build-depends: base >= 4" $+$ + text "cpp-options: -DBASE4" -- don't neeed the define yet, though + ) $+$ text "else" $+$ nest 4 ( + text "build-depends: base < 4" + ) $+$ + text "build-depends:" <+> + hsep (punctuate comma $ map text $ + ["HOC"] ++ map ("HOC-" ++) dependencies) $+$ + text "exposed-modules:" <+> sep (punctuate comma $ + map textBS $ BS.pack frameworkName : modules) $+$ + text "frameworks:" <+> text frameworkName + ) where modules = [ m | LocalModule m <- Set.toList $ Set.fromList $ ======================================= --- /branches/objc2/hoc/Tests/MiniFoundation.hs Fri Jan 9 17:57:45 2009 +++ /branches/objc2/hoc/Tests/MiniFoundation.hs Tue Aug 11 11:50:04 2009 @@ -1,13 +1,14 @@ {-# LANGUAGE TemplateHaskell, StandaloneDeriving, MultiParamTypeClasses, - TypeSynonymInstances, FlexibleInstances, RankNTypes #-} + TypeSynonymInstances, FlexibleInstances, RankNTypes, CPP #-} module MiniFoundation where import HOC import HOC.Exception ( WrappedNSException(..) ) import Foreign.C.Types -import Control.Exception ( catchDyn ) +import Control.Exception import System.IO.Unsafe ( unsafePerformIO ) +import Prelude hiding ( catch ) $(declareClass "NSObject" "ID") $(declareClass "NSString" "NSObject") @@ -109,8 +110,13 @@ catchNS :: IO a -> (NSException () -> IO a) -> IO a +#ifdef BASE4 +catchNS action handler + = action `catch` \(WrappedNSException exc) -> handler (castObject exc) +#else catchNS action handler = action `catchDyn` \(WrappedNSException exc) -> handler (castObject exc) +#endif -- NSMutableArray ======================================= --- /branches/objc2/hoc/Tests/TestFoundation.hs Fri Jan 9 17:57:45 2009 +++ /branches/objc2/hoc/Tests/TestFoundation.hs Tue Aug 11 11:50:04 2009 @@ -1,4 +1,5 @@ -{-# OPTIONS -fth -fglasgow-exts #-} +{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances, + MultiParamTypeClasses, RankNTypes, DeriveDataTypeable, CPP #-} module TestFoundation where import HOC @@ -13,7 +14,7 @@ import System.Mem ( performGC ) import Control.Concurrent ( threadDelay ) import Control.Monad ( when ) -import Control.Exception ( try, finally, catchDyn ) +import Control.Exception hiding ( assert ) import qualified System.Info( os ) @@ -300,7 +301,12 @@ let nilNumber = nil :: NSNumber () result <- try (nilNumber # intValue) expected <- try (fail "Message sent to nil: intValue") +#ifdef BASE4 + show (result :: Either SomeException CInt) + @?= show (expected :: Either SomeException CInt) +#else result @?= expected +#endif ) ], "Super" ~: test [ @@ -385,7 +391,12 @@ "HtoCtoH" ~: (do obj <- _ExceptionThrower # alloc >>= init result <- try (obj # throwHaskellException) +#ifdef BASE4 + show (result :: Either SomeException ()) + @?= "Left user error (Test Exception)" +#else show result @?= "Left user error (Test Exception)" +#endif ), "CtoHtoCtoH" ~: (do obj <- _ExceptionThrower # alloc >>= init |
|
From: <cod...@go...> - 2009-08-11 18:50:13
|
Revision: 389 Author: jam...@us... Date: Tue Aug 11 11:49:43 2009 Log: (objc2 branch) Include some instance declarations in generated .hs-boot files for bindings. http://code.google.com/p/hoc/source/detail?r=389 Modified: / /branches/objc2/hoc/InterfaceGenerator2/Output.hs ======================================= --- /branches/objc2/hoc/InterfaceGenerator2/Output.hs Wed Dec 10 08:29:58 2008 +++ /branches/objc2/hoc/InterfaceGenerator2/Output.hs Tue Aug 11 11:49:43 2009 @@ -66,7 +66,8 @@ <+> textBS (eHaskellName e) <> text "MetaClass") pprHsBoot entityPile modName entities - = text "module" <+> textBS modName <+> text "where" $+$ + = text "{-# OPTIONS -fglasgow-exts #-}" $+$ + text "module" <+> textBS modName <+> text "where" $+$ text "import HOC" $+$ vcat imports $+$ vcat classes @@ -84,7 +85,9 @@ <+> parens (textBS name <> char '_' <+> char 'a') $+$ text "type" <+> textBS name <> text "MetaClass" <+> char 'a' <+> equals <+> text (maybe "MetaClass" ( (++ "MetaClass") . BS.unpack . eHaskellName ) mbSuper) - <+> parens (textBS name <> char '_' <+> char 'a') + <+> parens (textBS name <> char '_' <+> char 'a') $+$ + text "instance" <+> text "ClassObject" <+> parens (textBS name <> text "Class" <+> text "()") $+$ + text "_" <> textBS name <+> text "::" <+> textBS name <> text "Class" <+> text "()" | (name, mbSuper) <- classes0 ] |
|
From: <cod...@go...> - 2009-08-11 18:23:51
|
Revision: 388 Author: wol...@gm... Date: Tue Aug 11 11:23:05 2009 Log: Have another shot at fixing the cabal build (issue #12). HOC_cbits.o is passed in via c-sources; Setup.hs now contains a hack that prevents the "ghc: no input files" problem. To be exact: the custom build hook arranges for a short shell script to be called instead of ghc. This shell script checks whether it is being called on HOC_cbits.o and silently ignores that command. For all other parameters, it invokes the actual ghc. http://code.google.com/p/hoc/source/detail?r=388 Modified: /trunk/hoc/HOC.cabal /trunk/hoc/Setup.hs ======================================= --- /trunk/hoc/HOC.cabal Sat Feb 14 12:53:11 2009 +++ /trunk/hoc/HOC.cabal Tue Aug 11 11:23:05 2009 @@ -64,7 +64,16 @@ hs-source-dirs: HOC extra-libraries: objc, ffi + + -- This is a hack. + -- Setup.hs contains code to build HOC_cbits.o from the + -- objective-c sources, as well as a matching hack to prevent + -- Cabal from invoking "ghc -c" on this file. Cabal will then + -- include HOC_cbits.o on the linker command line, which is the + -- whole point of this exercise. c-sources: HOC_cbits.o + + if os(darwin) include-dirs: /usr/include/ffi frameworks: Foundation ======================================= --- /trunk/hoc/Setup.hs Sun Dec 21 13:42:00 2008 +++ /trunk/hoc/Setup.hs Tue Aug 11 11:23:05 2009 @@ -5,6 +5,7 @@ import Distribution.Simple.PreProcess import Distribution.Simple.Configure import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program import System.Cmd( system ) import System.Exit( ExitCode(..) ) import System.Environment( getEnv ) @@ -99,6 +100,13 @@ extraFlags <- buildCBits (libBuildInfo libInfo) + -- add compiler flags required by C parts of HOC; + -- + -- HACK #1: + -- This passes the HOC_cbits.o object file on the + -- as a compiler flag so that template haskell can link + -- compile-time code. + let hooked_pd = pd { library = Just $ libInfo { libBuildInfo = addCompilerFlags extraFlags @@ -109,7 +117,42 @@ (executables pd) } - build hooked_pd lbi buildFlags knownSuffixHandlers + -- HACK #2: + -- HOC_cbits.o (built by buildCBits below) is specified in c-sources + -- for the library. Cabal reacts to this by invoking ghc -c HOC_cbits.o, + -- which ghc doesn't like. So, instead of calling ghc directly, we call + -- a short auto-generated shell script that does nothing in this case, + -- and calls the real ghc in all other cases. + -- After having "compiled" HOC_cbits.o in this way, Cabal will link + -- HOC_cbits.o as part of the library, which is what we want. + + let Just pr = lookupKnownProgram "ghc" (withPrograms lbi) + Just conf = lookupProgram pr (withPrograms lbi) + + ghcLocation = programLocation conf + + let fakeGHC = "./dist/build/fake-ghc.sh" + + writeFile fakeGHC $ unlines [ + "#!/bin/sh -e", + "case \"$*\" in", + " *HOC_cbits.o) true;;", + " *) \"" ++ locationPath ghcLocation ++ "\" \"$@\";;", + "esac" + ] + system $ "chmod +x " ++ fakeGHC + + let conf' = conf { programLocation = UserSpecified fakeGHC } + + progs' = updateProgram conf' (withPrograms lbi) + + let lbi' = lbi { + withPrograms = progs' + } + + -- call the default with our modified package description and + -- local build info + build hooked_pd lbi' buildFlags knownSuffixHandlers -- |Build HOC_cbits.o using the flags specified in the configuration -- stage, and return a list of flags to add to support usage of |
|
From: <cod...@go...> - 2009-08-11 17:39:15
|
Revision: 387 Author: wol...@gm... Date: Tue Aug 11 10:37:55 2009 Log: fix a typo http://code.google.com/p/hoc/source/detail?r=387 Modified: /trunk/hoc/InterfaceGenerator2/Output.hs ======================================= --- /trunk/hoc/InterfaceGenerator2/Output.hs Sat Feb 14 12:53:11 2009 +++ /trunk/hoc/InterfaceGenerator2/Output.hs Tue Aug 11 10:37:55 2009 @@ -290,7 +290,7 @@ = text "name:" <+> text "HOC-" <> text frameworkName $+$ text "version: 1.0" $+$ text "build-type: Simple" $+$ - text "Flag base" $+$ + text "Flag base4" $+$ text "Library" $+$ nest 4 ( text "if flag(base4)" $+$ nest 4 ( text "build-depends: base >= 4" $+$ |
|
From: <cod...@go...> - 2009-02-14 21:24:00
|
Author: wol...@gm...
Date: Sat Feb 14 12:53:11 2009
New Revision: 386
Modified:
trunk/hoc/Bindings/AdditionalCode/Foundation/NSException.hs
trunk/hoc/HOC.cabal
trunk/hoc/HOC/HOC/Exception.hs
trunk/hoc/InterfaceGenerator2/Output.hs
trunk/hoc/Tests/MiniFoundation.hs
trunk/hoc/Tests/TestFoundation.hs
Log:
add a flag for base 4.0 support
Modified: trunk/hoc/Bindings/AdditionalCode/Foundation/NSException.hs
==============================================================================
--- trunk/hoc/Bindings/AdditionalCode/Foundation/NSException.hs (original)
+++ trunk/hoc/Bindings/AdditionalCode/Foundation/NSException.hs Sat Feb 14
12:53:11 2009
@@ -1,10 +1,9 @@
--X catchNS
-import Control.Exception ( catchDyn )
-import HOC.Exception ( WrappedNSException(..) )
+import HOC.Exception ( WrappedNSException(..),
catchWrappedNSException )
-- CUT HERE
catchNS :: IO a -> (NSException () -> IO a) -> IO a
catchNS action handler
- = action `catchDyn` \(WrappedNSException exc) -> handler (castObject
exc)
+ = action `catchWrappedNSException` \(WrappedNSException exc) ->
handler (castObject exc)
Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal (original)
+++ trunk/hoc/HOC.cabal Sat Feb 14 12:53:11 2009
@@ -17,8 +17,15 @@
Flag ObjC2
description: build for Objective-C 2.0
+Flag base4
+
Library
- build-depends: base < 4, template-haskell, unix
+ build-depends: template-haskell, unix
+ if flag(base4)
+ build-depends: base >= 4, syb
+ cpp-options: -DBASE4
+ else
+ build-depends: base < 4
exposed-modules:
HOC,
@@ -87,7 +94,12 @@
cpp-options: -DTEST
- build-depends: HUnit
+ build-depends: HUnit, template-haskell, unix
+ if flag(base4)
+ build-depends: base >= 4, syb
+ cpp-options: -DBASE4
+ else
+ build-depends: base < 4
if !flag(Tests)
buildable: False
Modified: trunk/hoc/HOC/HOC/Exception.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Exception.hs (original)
+++ trunk/hoc/HOC/HOC/Exception.hs Sat Feb 14 12:53:11 2009
@@ -1,11 +1,12 @@
-{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}
+{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable,
+ ScopedTypeVariables, CPP #-}
module HOC.Exception where
import Data.Typeable
import Foreign
import Foreign.C.String ( CString, withCString )
import Prelude hiding ( catch )
-import Control.Exception ( Exception, evaluate, throwIO, throwDyn,
catchDyn, catch )
+import Control.Exception
import HOC.Base
import HOC.Arguments
@@ -14,11 +15,53 @@
data WrappedNSException = WrappedNSException (ID ())
deriving Typeable
+exceptionObjCToHaskell :: Ptr ObjCObject -> IO a
-foreign import ccall unsafe wrapHaskellException :: CString -> StablePtr
Exception -> IO (Ptr ObjCObject)
-foreign import ccall unsafe unwrapHaskellException :: Ptr ObjCObject -> IO
(StablePtr Exception)
+#ifdef BASE4
-exceptionObjCToHaskell :: Ptr ObjCObject -> IO a
+foreign import ccall unsafe wrapHaskellException
+ :: CString -> StablePtr SomeException -> IO (Ptr ObjCObject)
+foreign import ccall unsafe unwrapHaskellException
+ :: Ptr ObjCObject -> IO (StablePtr SomeException)
+
+-- get the exception pointer figure out if it is a NSException
+-- or a haskell exception and throw it.
+exceptionObjCToHaskell exception = do
+ sptr <- unwrapHaskellException exception
+ if (castStablePtrToPtr sptr == nullPtr)
+ then do
+ exc <- importArgument exception
+ throwIO $ WrappedNSException exc
+ else do
+ exc <- deRefStablePtr sptr
+ throwIO exc
+
+exceptionHaskellToObjC :: IO a -> IO (Ptr ObjCObject)
+
+exceptionHaskellToObjC action =
+ (action >> return nullPtr)
+ `catches` [
+ Handler $ \(WrappedNSException exc) -> exportArgument exc,
+ Handler $ \(exc :: SomeException) -> withCString (show exc) $
+ \cstr -> newStablePtr exc >>= wrapHaskellException cstr
+ ]
+
+instance Exception WrappedNSException where
+ toException = SomeException
+ fromException (SomeException ex) = cast ex
+
+instance Show WrappedNSException where
+ show (WrappedNSException ex) = "<<NSException>>"
+
+catchWrappedNSException :: IO a -> (WrappedNSException -> IO a) -> IO a
+catchWrappedNSException = catch
+
+#else
+
+foreign import ccall unsafe wrapHaskellException
+ :: CString -> StablePtr Exception -> IO (Ptr ObjCObject)
+foreign import ccall unsafe unwrapHaskellException
+ :: Ptr ObjCObject -> IO (StablePtr Exception)
-- get the exception pointer figure out if it is a NSException
-- or a haskell exception and throw it.
@@ -40,3 +83,8 @@
(\(WrappedNSException exc) -> exportArgument exc)
`catch`
(\exc -> withCString (show exc) $ \cstr -> newStablePtr exc >>=
wrapHaskellException cstr)
+
+catchWrappedNSException :: IO a -> (WrappedNSException -> IO a) -> IO a
+catchWrappedNSException = catchDyn
+
+#endif
Modified: trunk/hoc/InterfaceGenerator2/Output.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Output.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Output.hs Sat Feb 14 12:53:11 2009
@@ -290,13 +290,21 @@
= text "name:" <+> text "HOC-" <> text frameworkName $+$
text "version: 1.0" $+$
text "build-type: Simple" $+$
- text "build-depends:" <+>
- hsep (punctuate comma $ map text $
- ["base <4", "HOC"] ++ map ("HOC-" ++) dependencies) $+$
--- text "" $+$
- text "exposed-modules:" <+> sep (punctuate comma $
- map textBS $ BS.pack
frameworkName : modules) $+$
- text "frameworks:" <+> text frameworkName
+ text "Flag base" $+$
+ text "Library" $+$ nest 4 (
+ text "if flag(base4)" $+$ nest 4 (
+ text "build-depends: base >= 4" $+$
+ text "cpp-options: -DBASE4" -- don't neeed the define yet,
though
+ ) $+$ text "else" $+$ nest 4 (
+ text "build-depends: base < 4"
+ ) $+$
+ text "build-depends:" <+>
+ hsep (punctuate comma $ map text $
+ ["HOC"] ++ map ("HOC-" ++) dependencies) $+$
+ text "exposed-modules:" <+> sep (punctuate comma $
+ map textBS $ BS.pack
frameworkName : modules) $+$
+ text "frameworks:" <+> text frameworkName
+ )
where
modules = [ m | LocalModule m
<- Set.toList $ Set.fromList $
Modified: trunk/hoc/Tests/MiniFoundation.hs
==============================================================================
--- trunk/hoc/Tests/MiniFoundation.hs (original)
+++ trunk/hoc/Tests/MiniFoundation.hs Sat Feb 14 12:53:11 2009
@@ -1,13 +1,14 @@
{-# LANGUAGE TemplateHaskell, StandaloneDeriving, MultiParamTypeClasses,
- TypeSynonymInstances, FlexibleInstances, RankNTypes #-}
+ TypeSynonymInstances, FlexibleInstances, RankNTypes, CPP #-}
module MiniFoundation where
import HOC
import HOC.Exception ( WrappedNSException(..) )
import Foreign.C.Types
-import Control.Exception ( catchDyn )
+import Control.Exception
import System.IO.Unsafe ( unsafePerformIO )
+import Prelude hiding ( catch )
$(declareClass "NSObject" "ID")
$(declareClass "NSString" "NSObject")
@@ -109,8 +110,13 @@
catchNS :: IO a -> (NSException () -> IO a) -> IO a
+#ifdef BASE4
+catchNS action handler
+ = action `catch` \(WrappedNSException exc) -> handler (castObject exc)
+#else
catchNS action handler
= action `catchDyn` \(WrappedNSException exc) -> handler (castObject
exc)
+#endif
-- NSMutableArray
Modified: trunk/hoc/Tests/TestFoundation.hs
==============================================================================
--- trunk/hoc/Tests/TestFoundation.hs (original)
+++ trunk/hoc/Tests/TestFoundation.hs Sat Feb 14 12:53:11 2009
@@ -1,4 +1,5 @@
-{-# OPTIONS -fth -fglasgow-exts #-}
+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances,
+ MultiParamTypeClasses, RankNTypes, DeriveDataTypeable, CPP #-}
module TestFoundation where
import HOC
@@ -13,7 +14,7 @@
import System.Mem ( performGC )
import Control.Concurrent ( threadDelay )
import Control.Monad ( when )
-import Control.Exception ( try, finally, catchDyn )
+import Control.Exception hiding ( assert )
import qualified System.Info( os )
@@ -300,7 +301,12 @@
let nilNumber = nil :: NSNumber ()
result <- try (nilNumber # intValue)
expected <- try (fail "Message sent to nil: intValue")
+#ifdef BASE4
+ show (result :: Either SomeException CInt)
+ @?= show (expected :: Either SomeException CInt)
+#else
result @?= expected
+#endif
)
],
"Super" ~: test [
@@ -385,7 +391,12 @@
"HtoCtoH" ~: (do
obj <- _ExceptionThrower # alloc >>= init
result <- try (obj # throwHaskellException)
+#ifdef BASE4
+ show (result :: Either SomeException ())
+ @?= "Left user error (Test Exception)"
+#else
show result @?= "Left user error (Test Exception)"
+#endif
),
"CtoHtoCtoH" ~: (do
obj <- _ExceptionThrower # alloc >>= init
|
|
From: <cod...@go...> - 2009-01-13 16:54:54
|
Author: jam...@us...
Date: Tue Jan 13 08:54:16 2009
New Revision: 385
Modified:
/ (props changed)
trunk/hoc/InterfaceGenerator2/Output.hs
Log:
Quick fix in InterfaceGenerator2 to make bindings build on ghc 6.10:
adds "<4" to the "base" dependency in the generated cabal file. A more
complete fix could be to add cabal file splicing and/or pragma splicing to
the AdditionalCode handling system.
Modified: trunk/hoc/InterfaceGenerator2/Output.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Output.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Output.hs Tue Jan 13 08:54:16 2009
@@ -292,7 +292,7 @@
text "build-type: Simple" $+$
text "build-depends:" <+>
hsep (punctuate comma $ map text $
- ["base", "HOC"] ++ map ("HOC-" ++) dependencies) $+$
+ ["base <4", "HOC"] ++ map ("HOC-" ++) dependencies) $+$
-- text "" $+$
text "exposed-modules:" <+> sep (punctuate comma $
map textBS $ BS.pack
frameworkName : modules) $+$
|
|
From: <cod...@go...> - 2009-01-10 02:20:02
|
Author: jam...@us...
Date: Fri Jan 9 18:06:02 2009
New Revision: 384
Modified:
/ (props changed)
branches/objc2/hoc/HOC/HOC/NewClass.hs
Log:
Fixing merge error - I accidentally took 2 versions of the same function.
Modified: branches/objc2/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/NewClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/NewClass.hs Fri Jan 9 18:06:02 2009
@@ -109,8 +109,6 @@
setHaskellReleaseMethod methodList idx super =
setMethodInList methodList idx releaseSelector "v@:" releaseCif
(haskellObject_release_IMP super)
-setHaskellReleaseMethod methodList idx =
- setMethodInList methodList idx releaseSelector "v@:" releaseCif
haskellObject_release_IMP
setHaskellDataMethod methodList idx super mbDat =
setMethodInList methodList idx getHaskellDataSelector "^v@:#"
getHaskellDataCif (getHaskellData_IMP super mbDat)
|
|
From: <cod...@go...> - 2009-01-10 01:59:43
|
Author: jam...@us...
Date: Fri Jan 9 17:57:45 2009
New Revision: 383
Modified:
/ (props changed)
branches/objc2/hoc/ (props changed)
branches/objc2/hoc/HOC.cabal
branches/objc2/hoc/HOC/HOC/Exception.hs
branches/objc2/hoc/HOC/HOC/NewClass.hs
branches/objc2/hoc/HOC/HOC/StdArgumentTypes.hs
branches/objc2/hoc/HOC_cbits/Ivars.h (props changed)
branches/objc2/hoc/HOC_cbits/Methods.h (props changed)
branches/objc2/hoc/InterfaceGenerator2/Headers.hs
branches/objc2/hoc/InterfaceGenerator2/ParserBase.hs
branches/objc2/hoc/Tests/MiniFoundation.hs
branches/objc2/hoc/Tests/TestFoundation.hs
Log:
merging trunk back to objc2 branch
Modified: branches/objc2/hoc/HOC.cabal
==============================================================================
--- branches/objc2/hoc/HOC.cabal (original)
+++ branches/objc2/hoc/HOC.cabal Fri Jan 9 17:57:45 2009
@@ -18,7 +18,7 @@
description: build for Objective-C 2.0
Library
- build-depends: base, template-haskell, unix
+ build-depends: base < 4, template-haskell, unix
exposed-modules:
HOC,
Modified: branches/objc2/hoc/HOC/HOC/Exception.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/Exception.hs (original)
+++ branches/objc2/hoc/HOC/HOC/Exception.hs Fri Jan 9 17:57:45 2009
@@ -5,7 +5,7 @@
import Foreign
import Foreign.C.String ( CString, withCString )
import Prelude hiding ( catch )
-import Control.Exception ( evaluate, throwIO, throwDyn, catchDyn, catch
)
+import Control.Exception ( Exception, evaluate, throwIO, throwDyn,
catchDyn, catch )
import HOC.Base
import HOC.Arguments
@@ -15,8 +15,8 @@
deriving Typeable
-foreign import ccall unsafe wrapHaskellException :: CString -> StablePtr a
-> IO (Ptr ObjCObject)
-foreign import ccall unsafe unwrapHaskellException :: Ptr ObjCObject -> IO
(StablePtr a)
+foreign import ccall unsafe wrapHaskellException :: CString -> StablePtr
Exception -> IO (Ptr ObjCObject)
+foreign import ccall unsafe unwrapHaskellException :: Ptr ObjCObject -> IO
(StablePtr Exception)
exceptionObjCToHaskell :: Ptr ObjCObject -> IO a
Modified: branches/objc2/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/NewClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/NewClass.hs Fri Jan 9 17:57:45 2009
@@ -109,6 +109,8 @@
setHaskellReleaseMethod methodList idx super =
setMethodInList methodList idx releaseSelector "v@:" releaseCif
(haskellObject_release_IMP super)
+setHaskellReleaseMethod methodList idx =
+ setMethodInList methodList idx releaseSelector "v@:" releaseCif
haskellObject_release_IMP
setHaskellDataMethod methodList idx super mbDat =
setMethodInList methodList idx getHaskellDataSelector "^v@:#"
getHaskellDataCif (getHaskellData_IMP super mbDat)
Modified: branches/objc2/hoc/HOC/HOC/StdArgumentTypes.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/StdArgumentTypes.hs (original)
+++ branches/objc2/hoc/HOC/HOC/StdArgumentTypes.hs Fri Jan 9 17:57:45 2009
@@ -78,6 +78,16 @@
withUTF8String str = withArray0 0 (unicodeToUtf8 str)
+instance ObjCArgument a (Ptr b) => ObjCArgument (Maybe a) (Ptr b) where
+ withExportedArgument Nothing action = action nullPtr
+ withExportedArgument (Just x) action = withExportedArgument x action
+ exportArgument Nothing = return nullPtr
+ exportArgument (Just x) = exportArgument x
+ importArgument p
+ | p == nullPtr = return Nothing
+ | otherwise = fmap Just (importArgument p)
+ objCTypeString _ = objCTypeString (undefined :: a)
+
instance ObjCArgument String (Ptr ObjCObject) where
withExportedArgument arg action =
bracket (withUTF8String arg utf8ToNSString) releaseObject action
@@ -88,4 +98,4 @@
importArgument arg = nsStringToUTF8 arg >>= peekArray0 0
>>= return . utf8ToUnicode
- objCTypeString _ = "*"
+ objCTypeString _ = "@"
Modified: branches/objc2/hoc/InterfaceGenerator2/Headers.hs
==============================================================================
--- branches/objc2/hoc/InterfaceGenerator2/Headers.hs (original)
+++ branches/objc2/hoc/InterfaceGenerator2/Headers.hs Fri Jan 9 17:57:45
2009
@@ -12,7 +12,7 @@
import Control.Monad(when)
import Data.Char(isAlphaNum, toUpper)
import Data.List(isPrefixOf,isSuffixOf)
-import Data.Maybe(mapMaybe)
+import Data.Maybe(mapMaybe, maybeToList)
import System.Directory(getDirectoryContents, doesDirectoryExist)
import System.Info(os)
import Text.Parsec( runParserT )
@@ -89,9 +89,9 @@
graph :: Gr () ()
graph = mkUGraph [ 0 .. length loaded - 1 ]
[ (to, from) | (_, name, includes, _) <- loaded,
- from <- Map.lookup name
namesToNums,
+ from <- maybeToList $ Map.lookup
name namesToNums,
include <- includes,
- to <- Map.lookup include
namesToNums ]
+ to <- maybeToList $ Map.lookup
include namesToNums ]
sorted = map (numsToHeaders Map.!) $ topsort graph
process ( (headerFileName, moduleName, imports, contents) :
moreHeaders ) env accum
Modified: branches/objc2/hoc/InterfaceGenerator2/ParserBase.hs
==============================================================================
--- branches/objc2/hoc/InterfaceGenerator2/ParserBase.hs (original)
+++ branches/objc2/hoc/InterfaceGenerator2/ParserBase.hs Fri Jan 9
17:57:45 2009
@@ -21,7 +21,13 @@
= fst $ runMessages $ runParserT parser emptyParseEnvironment fileName
text
lookupIntegerConstant :: String -> Parser Integer
-lookupIntegerConstant name = getState >>= Map.lookup name
+lookupIntegerConstant name = getState >>= mapLookup name
+ where
+ -- ghc 6.10's containers package no longer allows arbitrary
+ -- monads in its return types
+ mapLookup k v = case Map.lookup k v of
+ Nothing -> fail "Integer constant not found"
+ Just x -> return x
defineIntegerConstant :: String -> Integer -> Parser ()
defineIntegerConstant name value = modifyState (Map.insert name value)
Modified: branches/objc2/hoc/Tests/MiniFoundation.hs
==============================================================================
--- branches/objc2/hoc/Tests/MiniFoundation.hs (original)
+++ branches/objc2/hoc/Tests/MiniFoundation.hs Fri Jan 9 17:57:45 2009
@@ -115,8 +115,10 @@
-- NSMutableArray
$(declareSelector "addObject:" [t| forall t1 . ID t1 -> IO () |])
+$(declareSelector "objectAtIndex:" [t| forall a. CUInt -> IO (ID a) |] )
instance Has_addObject (NSMutableArray a)
+instance Has_objectAtIndex (NSMutableArray a)
deriving instance Show NSRect
deriving instance Show NSPoint
Modified: branches/objc2/hoc/Tests/TestFoundation.hs
==============================================================================
--- branches/objc2/hoc/Tests/TestFoundation.hs (original)
+++ branches/objc2/hoc/Tests/TestFoundation.hs Fri Jan 9 17:57:45 2009
@@ -48,8 +48,15 @@
instance Has_otherObject (HaskellObjectWithOutlet a)
instance Has_setOtherObject (HaskellObjectWithOutlet a)
+$(declareSelector "maybeString" [t| IO (Maybe String) |])
+$(declareSelector "setMaybeString:" [t| Maybe String -> IO () |] )
+
+instance Has_maybeString (HaskellObjectWithOutlet a)
+instance Has_setMaybeString (HaskellObjectWithOutlet a)
+
$(exportClass "HaskellObjectWithOutlet" "ho1_" [
- Outlet "otherObject" [t| ID () |]
+ Outlet "otherObject" [t| ID () |],
+ Outlet "maybeString" [t| NSString () |]
])
$(declareClass "HaskellObjectWithDescription" "NSObject")
@@ -214,6 +221,37 @@
hobj # setOtherObject num
num' <- hobj # otherObject >>= return . castObject
when (num /= num') $ assert "Different Object returned."
+ ),
+ "set-forget-reget" ~: (assertNoLeaks $ do
+ -- set an ivar, 'forget' the object (stash it outside
haskell-space),
+ -- run the GC, 'remember' the object, and read the ivar.
+
+ -- this catches a class of bug which helped me grok
HSOs ;-)
+
+ (num, array) <- assertLeaks 3 $ do
+ num <- _NSNumber # alloc >>= initWithInt 42
+ hobj <- _HaskellObjectWithOutlet # alloc >>= init
+ hobj # setOtherObject num
+
+ array <- _NSMutableArray # alloc >>= init
+ array # addObject hobj
+
+ return (num, array)
+
+ assertLeaks (-3) $ do
+ hobj <- array # objectAtIndex 0 :: IO
(HaskellObjectWithOutlet ())
+
+ num' <- hobj # otherObject >>= return . castObject
+ when (num /= num') $ assert "Different Object
returned."
+ ),
+ "set-get-maybeString" ~: (assertNoLeaks $ do
+ hobj <- _HaskellObjectWithOutlet # alloc >>= init
+ nothing <- hobj # maybeString
+ nothing @?= Nothing
+
+ hobj # setMaybeString (Just "42")
+ just42 <- hobj # maybeString
+ just42 @?= Just "42"
)
],
"HaskellObjectWithIVar" ~: test [
|
|
From: <cod...@go...> - 2009-01-10 01:50:35
|
Author: jam...@us...
Date: Fri Jan 9 17:28:12 2009
New Revision: 382
Modified:
/ (props changed)
trunk/hoc/HOC/HOC/StdArgumentTypes.hs
trunk/hoc/Tests/MiniFoundation.hs
trunk/hoc/Tests/TestFoundation.hs
Log:
Added an ObjCArgument instance for Maybe versions of all Ptr-marshalled
types which maps nullPtr to Nothing.
Also added test cases for this and for something else I noticed a while
back (not a bug in HOC, but a bug in some experiments I had been doing with
ID marshalling). It's somewhat redundant, but gives a good illustration of
why certain other tests were failing in my experiments.
Modified: trunk/hoc/HOC/HOC/StdArgumentTypes.hs
==============================================================================
--- trunk/hoc/HOC/HOC/StdArgumentTypes.hs (original)
+++ trunk/hoc/HOC/HOC/StdArgumentTypes.hs Fri Jan 9 17:28:12 2009
@@ -78,6 +78,16 @@
withUTF8String str = withArray0 0 (unicodeToUtf8 str)
+instance ObjCArgument a (Ptr b) => ObjCArgument (Maybe a) (Ptr b) where
+ withExportedArgument Nothing action = action nullPtr
+ withExportedArgument (Just x) action = withExportedArgument x action
+ exportArgument Nothing = return nullPtr
+ exportArgument (Just x) = exportArgument x
+ importArgument p
+ | p == nullPtr = return Nothing
+ | otherwise = fmap Just (importArgument p)
+ objCTypeString _ = objCTypeString (undefined :: a)
+
instance ObjCArgument String (Ptr ObjCObject) where
withExportedArgument arg action =
bracket (withUTF8String arg utf8ToNSString) releaseObject action
Modified: trunk/hoc/Tests/MiniFoundation.hs
==============================================================================
--- trunk/hoc/Tests/MiniFoundation.hs (original)
+++ trunk/hoc/Tests/MiniFoundation.hs Fri Jan 9 17:28:12 2009
@@ -115,8 +115,10 @@
-- NSMutableArray
$(declareSelector "addObject:" [t| forall t1 . ID t1 -> IO () |])
+$(declareSelector "objectAtIndex:" [t| forall a. CUInt -> IO (ID a) |] )
instance Has_addObject (NSMutableArray a)
+instance Has_objectAtIndex (NSMutableArray a)
deriving instance Show NSRect
deriving instance Show NSPoint
Modified: trunk/hoc/Tests/TestFoundation.hs
==============================================================================
--- trunk/hoc/Tests/TestFoundation.hs (original)
+++ trunk/hoc/Tests/TestFoundation.hs Fri Jan 9 17:28:12 2009
@@ -48,8 +48,15 @@
instance Has_otherObject (HaskellObjectWithOutlet a)
instance Has_setOtherObject (HaskellObjectWithOutlet a)
+$(declareSelector "maybeString" [t| IO (Maybe String) |])
+$(declareSelector "setMaybeString:" [t| Maybe String -> IO () |] )
+
+instance Has_maybeString (HaskellObjectWithOutlet a)
+instance Has_setMaybeString (HaskellObjectWithOutlet a)
+
$(exportClass "HaskellObjectWithOutlet" "ho1_" [
- Outlet "otherObject" [t| ID () |]
+ Outlet "otherObject" [t| ID () |],
+ Outlet "maybeString" [t| NSString () |]
])
$(declareClass "HaskellObjectWithDescription" "NSObject")
@@ -214,6 +221,37 @@
hobj # setOtherObject num
num' <- hobj # otherObject >>= return . castObject
when (num /= num') $ assert "Different Object returned."
+ ),
+ "set-forget-reget" ~: (assertNoLeaks $ do
+ -- set an ivar, 'forget' the object (stash it outside
haskell-space),
+ -- run the GC, 'remember' the object, and read the ivar.
+
+ -- this catches a class of bug which helped me grok
HSOs ;-)
+
+ (num, array) <- assertLeaks 3 $ do
+ num <- _NSNumber # alloc >>= initWithInt 42
+ hobj <- _HaskellObjectWithOutlet # alloc >>= init
+ hobj # setOtherObject num
+
+ array <- _NSMutableArray # alloc >>= init
+ array # addObject hobj
+
+ return (num, array)
+
+ assertLeaks (-3) $ do
+ hobj <- array # objectAtIndex 0 :: IO
(HaskellObjectWithOutlet ())
+
+ num' <- hobj # otherObject >>= return . castObject
+ when (num /= num') $ assert "Different Object
returned."
+ ),
+ "set-get-maybeString" ~: (assertNoLeaks $ do
+ hobj <- _HaskellObjectWithOutlet # alloc >>= init
+ nothing <- hobj # maybeString
+ nothing @?= Nothing
+
+ hobj # setMaybeString (Just "42")
+ just42 <- hobj # maybeString
+ just42 @?= Just "42"
)
],
"HaskellObjectWithIVar" ~: test [
|
|
From: <cod...@go...> - 2009-01-10 01:26:34
|
Author: jam...@us...
Date: Fri Jan 9 16:57:16 2009
New Revision: 381
Modified:
/ (props changed)
trunk/hoc/HOC/HOC/StdArgumentTypes.hs
Log:
Fixed argument type code for String ("*" is for C strings - should be "@"
for an object - I assume this is true in GNUStep too?)
Modified: trunk/hoc/HOC/HOC/StdArgumentTypes.hs
==============================================================================
--- trunk/hoc/HOC/HOC/StdArgumentTypes.hs (original)
+++ trunk/hoc/HOC/HOC/StdArgumentTypes.hs Fri Jan 9 16:57:16 2009
@@ -88,4 +88,4 @@
importArgument arg = nsStringToUTF8 arg >>= peekArray0 0
>>= return . utf8ToUnicode
- objCTypeString _ = "*"
+ objCTypeString _ = "@"
|
|
From: <cod...@go...> - 2009-01-10 01:15:29
|
Author: jam...@us...
Date: Fri Jan 9 16:57:06 2009
New Revision: 380
Modified:
/ (props changed)
branches/objc2/hoc/HOC/HOC/ExportClass.hs
branches/objc2/hoc/HOC/HOC/ID.hs
branches/objc2/hoc/HOC/HOC/NewClass.hs
branches/objc2/hoc/HOC_cbits/MemoryManagement.h
branches/objc2/hoc/HOC_cbits/MemoryManagement.m
Log:
(objc2 branch) Rewrote retain/release to call superclass's implementations.
Modified: branches/objc2/hoc/HOC/HOC/ExportClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/ExportClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/ExportClass.hs Fri Jan 9 16:57:06 2009
@@ -130,8 +130,8 @@
ivars <- makeDefaultIvarList
imethods <- makeMethodList (nIMethods+3)
cmethods <- makeMethodList nCMethods
- setHaskellRetainMethod imethods 0
- setHaskellReleaseMethod imethods 1
+ setHaskellRetainMethod imethods 0 super
+ setHaskellReleaseMethod imethods 1 super
setHaskellDataMethod imethods 2 super (
Just ($(typedInitIvars) >>= return . toDyn)
)
Modified: branches/objc2/hoc/HOC/HOC/ID.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/ID.hs (original)
+++ branches/objc2/hoc/HOC/HOC/ID.hs Fri Jan 9 16:57:06 2009
@@ -8,7 +8,7 @@
import Control.Concurrent.MVar
import Control.Exception(evaluate,assert)
-import Control.Monad(when)
+import Control.Monad(when, join)
import System.IO.Unsafe(unsafePerformIO)
import System.Mem.Weak
import Foreign.Ptr
@@ -21,6 +21,12 @@
data ID a = ID HSO | Nil
+dPutStrLn = if {--} False --} True
+ then putStrLn
+ else const $ return ()
+
+dPutWords = dPutStrLn . unwords
+
nil = Nil
castObject (ID a) = ID a
@@ -59,6 +65,13 @@
objectMapLock = unsafePerformIO $ newMVar ()
{-# NOINLINE objectMapLock #-}
+withObjectMapLock taker action = do
+ dPutWords [">", "withObjectMapLock", taker]
+ res <- withMVar objectMapLock $ \_ -> action
+ dPutWords ["<", "withObjectMapLock", taker]
+ return res
+
+
-- given a pointer to an ObjCObject, return a stablePtr to a Weak
reference to
-- a HSO
foreign import ccall unsafe "ObjectMap.h getHaskellPart"
@@ -91,13 +104,21 @@
getRetainedHaskellPart :: Ptr ObjCObject -> IO (StablePtr HSO)
foreign import ccall unsafe "RetainedHaskellPart.h setRetainedHaskellPart"
setRetainedHaskellPart :: Ptr ObjCObject -> StablePtr HSO -> IO ()
-
-foreign import ccall unsafe "NSObjectReferenceCount.h
NSIncrementExtraRefCount"
- nsIncrementExtraRefCount :: Ptr ObjCObject -> IO ()
-foreign import ccall unsafe "NSObjectReferenceCount.h
NSDecrementExtraRefCountWasZero"
- nsDecrementExtraRefCountWasZero :: Ptr ObjCObject -> IO CChar{-BOOL-}
-foreign import ccall unsafe "NSObjectReferenceCount.h NSExtraRefCount"
- nsExtraRefCount :: Ptr ObjCObject -> IO CUInt
+replaceRetainedHaskellPart :: Ptr ObjCObject -> StablePtr HSO -> IO ()
+replaceRetainedHaskellPart self newHSO = do
+ dPutWords ["replaceRetainedHaskellPart", show self, show
(castStablePtrToPtr newHSO)]
+ oldHSO <- getRetainedHaskellPart self
+ when (oldHSO /= newHSO) $ do
+ when (castStablePtrToPtr oldHSO /= nullPtr) $ do
+ freeStablePtr oldHSO
+ setRetainedHaskellPart self newHSO
+
+foreign import ccall "MemoryManagement.h retainSuper"
+ retainSuper :: Ptr ObjCObject -> Ptr ObjCObject -> IO ()
+foreign import ccall "MemoryManagement.h releaseSuper"
+ releaseSuper :: Ptr ObjCObject -> Ptr ObjCObject -> IO ()
+foreign import ccall unsafe "MemoryManagement.h retainCount"
+ retainCount :: Ptr ObjCObject -> IO CUInt
-- Since finalizers are executed in arbitrary threads, we must
-- ensure that we establish an autoreleasepool for the duration
@@ -147,11 +168,13 @@
importImmortal = importArgument' True
--- this is where the mogic happens.
+-- this is where the magic happens.
importArgument' immortal p
| p == nullPtr = return Nil
- -- objectMapLock is a global, thanks to unsafePerformIO
- | otherwise = withMVar objectMapLock $ \_ -> do
+ -- do what needs to be done in the lock, return what
+ -- needs to be done outside the lock (specifically,
+ -- the retain needs to be done outside the lock).
+ | otherwise = join $ withObjectMapLock "importArgument'" $ do
sptr <- getHaskellPart p
mbHaskellObj <-
if castStablePtrToPtr sptr /= nullPtr
@@ -162,39 +185,31 @@
return Nothing
case mbHaskellObj of
-- if the HSO already exists, we're done!
- Just haskellObj -> return $ ID haskellObj
+ Just haskellObj -> return $ return $ ID haskellObj
-- notice that the finalizer definition requires new_sptr
Nothing -> mdo {- it's much more pratical than fixM -}
haskellData <- makeNewHaskellData p
+ dPutWords ["got haskell data", show haskellData]
let haskellObj = HSO p (fromMaybe [] haskellData)
- finalizer | isJust haskellData = Just $
finalizeHaskellID p new_sptr
- | immortal = Nothing
+ finalizer | immortal = Nothing
| otherwise = Just $ finalizeID p new_sptr
wptr <- mkWeakPtr haskellObj finalizer
new_sptr <- newStablePtr wptr
setHaskellPart p new_sptr (if immortal then 1 else 0)
- case haskellData of
- Just _ -> haskellObject_retain p
- Nothing -> retainObject p
-
- return $ ID haskellObj
+ return $ do
+ -- retain the object, but do it outside the
+ -- lock because the retain IMP may need the lock.
+ retainObject p
+ return $ ID haskellObj
finalizeID :: Ptr ObjCObject -> StablePtr (Weak HSO) -> IO ()
finalizeID cObj sptr = do
- withMVar objectMapLock $ \_ -> removeHaskellPart cObj sptr
+ withObjectMapLock "finalizeID" $ removeHaskellPart cObj sptr
+
releaseObjectWithPool cObj
freeStablePtr sptr
-finalizeHaskellID :: Ptr ObjCObject -> StablePtr (Weak HSO) -> IO ()
-finalizeHaskellID cObj sptr = do
- withMVar objectMapLock $ \_ -> removeHaskellPart cObj sptr
- extraRefs <- nsExtraRefCount cObj
- -- putStrLn "destroy haskelll object"
- assert (extraRefs == 0) (deallocObjectWithPool cObj)
- freeStablePtr sptr
-
---
makeNewHaskellData p = do
stable <- getNewHaskellData p
if (castStablePtrToPtr stable == nullPtr)
@@ -204,77 +219,74 @@
freeStablePtr stable
return (Just dat)
-haskellObject_retain_IMP :: FFICif -> Ptr () -> Ptr (Ptr ()) -> IO (Ptr
ObjCObject)
-haskellObject_retain_IMP cif ret args = do
+haskellObject_retain_IMP :: Ptr ObjCObject -> FFICif -> Ptr () -> Ptr (Ptr
()) -> IO (Ptr ObjCObject)
+haskellObject_retain_IMP super cif ret args = do
selfPtr <- peekElemOff args 0
self <- peek (castPtr selfPtr) :: IO (Ptr ObjCObject)
poke (castPtr ret) self -- retain returns self
- -- putStrLn "retain haskell object_IMP"
- withMVar objectMapLock $ \_ -> haskellObject_retain self
+ dPutWords ["haskellObject_retain_IMP", show super, "<FFICif>", show
ret, show args]
+ haskellObject_retain self super
return nullPtr -- no exception
-haskellObject_retain self = do
- -- putStrLn "retain haskell object"
- nsIncrementExtraRefCount self
+haskellObject_retain self super = do
+ dPutWords ["haskellObject_retain", show self, show super]
+ retainSuper self super
+ dPutStrLn "retained super"
- stablePtrToHaskellSelf <- getRetainedHaskellPart self
- when (castStablePtrToPtr stablePtrToHaskellSelf == nullPtr) $ do
- stableWeakPtrToHaskellSelf <- getHaskellPart self
- when (castStablePtrToPtr stableWeakPtrToHaskellSelf /= nullPtr) $
do
- weakPtrToHaskellSelf <- deRefStablePtr
stableWeakPtrToHaskellSelf
- mbHaskellSelf <- deRefWeak weakPtrToHaskellSelf
- case mbHaskellSelf of
- Just haskellSelf -> do
- stablePtrToHaskellSelf <- newStablePtr haskellSelf
- setRetainedHaskellPart self stablePtrToHaskellSelf
- Nothing ->
- -- The weak pointer will only be dealloced when there
are
- -- no known references from ObjC and no references
from Haskell.
- -- So if we get here, it's not my bug (hopefully).
- -- When an object is exported (returned or passed as a
parameter)
- -- from Haskell, it is retained and autoreleased, so
passing an
- -- object from Haskell to Objective C and immediately
forgetting
- -- the reference (before ObjC has a chance to retain
it) is safe.
-
- error "Error: Retaining Haskell Object that has
already been released"
+ withObjectMapLock "haskellObject_retain" $ do
+ stablePtrToHaskellSelf <- getRetainedHaskellPart self
+ when (castStablePtrToPtr stablePtrToHaskellSelf == nullPtr) $ do
+ stableWeakPtrToHaskellSelf <- getHaskellPart self
+ when (castStablePtrToPtr stableWeakPtrToHaskellSelf /=
nullPtr) $ do
+ weakPtrToHaskellSelf <- deRefStablePtr
stableWeakPtrToHaskellSelf
+ mbHaskellSelf <- deRefWeak weakPtrToHaskellSelf
+ case mbHaskellSelf of
+ Just haskellSelf -> do
+ stablePtrToHaskellSelf <- newStablePtr haskellSelf
+ setRetainedHaskellPart self stablePtrToHaskellSelf
+ Nothing ->
+ -- The weak pointer will only be dealloced when
there are
+ -- no known references from ObjC and no references
from Haskell.
+ -- So if we get here, it's not my bug (hopefully).
+ -- When an object is exported (returned or passed
as a parameter)
+ -- from Haskell, it is retained and autoreleased,
so passing an
+ -- object from Haskell to Objective C and
immediately forgetting
+ -- the reference (before ObjC has a chance to
retain it) is safe.
+
+ error "Error: Retaining Haskell Object that has
already been released"
-haskellObject_release_IMP :: FFICif -> Ptr () -> Ptr (Ptr ()) -> IO (Ptr
ObjCObject)
-haskellObject_release_IMP cif ret args = do
+haskellObject_release_IMP :: Ptr ObjCObject -> FFICif -> Ptr () -> Ptr
(Ptr ()) -> IO (Ptr ObjCObject)
+haskellObject_release_IMP super cif ret args = do
selfPtr <- peekElemOff args 0
self <- peek (castPtr selfPtr) :: IO (Ptr ObjCObject)
- -- putStrLn "release haskell object_IMP"
- withMVar objectMapLock $ \_ -> haskellObject_release self
+ dPutWords ["haskellObject_release_IMP", show super, "<FFICif>", show
ret, show args]
+ haskellObject_release super self
return nullPtr -- no exception
-haskellObject_release self = do
- -- putStrLn "release haskell object"
- wasZero <- nsDecrementExtraRefCountWasZero self
- -- nobody else should call NSDecrementExtraRefCountWasZero anyway,
- -- and we're protected from ourselves by the objectMapLock
- -- ==> no race condition here
- refCount <- nsExtraRefCount self
+haskellObject_release super self = do
+ dPutWords ["haskellObject_release", show super, show self]
+ retainCount+1 <- retainCount self
+ -- retainCount+1 because we want to know the retainCount after we
+ -- release; if it's about to become zero, then we won't be
+ -- able to call retainCount on self after the call to releaseSuper.
+ releaseSuper self super
+ -- retainCount should now contain the current retain count.
- when (refCount == 0) $ do
+ when (retainCount == 1) $ withObjectMapLock "haskellObject_release" $
do
-- no extra references
-- Only the reference from the Haskell part remains,
-- which means we do no longer want to have a stable pointer
-- (if we have one, that is)
- stablePtrToHaskellSelf <- getRetainedHaskellPart self
- when (castStablePtrToPtr stablePtrToHaskellSelf /= nullPtr) $ do
- freeStablePtr stablePtrToHaskellSelf
- setRetainedHaskellPart self (castPtrToStablePtr nullPtr)
-
- when (wasZero /= 0) $ do
- deallocObject self
+ replaceRetainedHaskellPart self (castPtrToStablePtr nullPtr)
-- this is the implementation of the __getHaskellData__ selector.
getHaskellData_IMP :: Ptr ObjCObject -> Maybe (IO Dynamic)
-> FFICif -> Ptr () -> Ptr (Ptr ()) -> IO (Ptr
ObjCObject)
getHaskellData_IMP super mbDat cif ret args = do
- -- putStrLn "__getHaskellData__"
selfPtr <- peekElemOff args 0
self <- peek (castPtr selfPtr) :: IO (Ptr ObjCObject)
+ dPutWords ["__getHaskellData__", show self, show super]
superDataStable <- getNewHaskellDataForClass self super
superData <- if castStablePtrToPtr superDataStable == nullPtr
then do
Modified: branches/objc2/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/NewClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/NewClass.hs Fri Jan 9 16:57:06 2009
@@ -95,20 +95,20 @@
return list
retainSelector = getSelectorForName "retain"
-retainCif = getCifForSelector (undefined :: ID () -> IO (ID ()))
+retainCif = getCifForSelector (undefined :: Class () -> ID () -> IO (ID
()))
releaseSelector = getSelectorForName "release"
-releaseCif = getCifForSelector (undefined :: ID () -> IO ())
+releaseCif = getCifForSelector (undefined :: Class () -> ID () -> IO ())
getHaskellDataSelector = getSelectorForName "__getHaskellData__"
getHaskellDataCif = getCifForSelector (undefined :: Class () -> ID () ->
IO (ID ()))
-- actually -> IO (Ptr
()) ...
-setHaskellRetainMethod methodList idx =
- setMethodInList methodList idx retainSelector "@@:" retainCif
haskellObject_retain_IMP
+setHaskellRetainMethod methodList idx super =
+ setMethodInList methodList idx retainSelector "@@:" retainCif
(haskellObject_retain_IMP super)
-setHaskellReleaseMethod methodList idx =
- setMethodInList methodList idx releaseSelector "v@:" releaseCif
haskellObject_release_IMP
+setHaskellReleaseMethod methodList idx super =
+ setMethodInList methodList idx releaseSelector "v@:" releaseCif
(haskellObject_release_IMP super)
setHaskellDataMethod methodList idx super mbDat =
setMethodInList methodList idx getHaskellDataSelector "^v@:#"
getHaskellDataCif (getHaskellData_IMP super mbDat)
Modified: branches/objc2/hoc/HOC_cbits/MemoryManagement.h
==============================================================================
--- branches/objc2/hoc/HOC_cbits/MemoryManagement.h (original)
+++ branches/objc2/hoc/HOC_cbits/MemoryManagement.h Fri Jan 9 16:57:06 2009
@@ -8,6 +8,11 @@
void retainObject(id obj);
void releaseObject(id obj);
+
+void retainSuper(id obj, Class cls);
+void releaseSuper(id obj, Class cls);
+unsigned int retainCount(id obj);
+
void deallocObject(id obj);
void autoreleaseObject(id obj);
Modified: branches/objc2/hoc/HOC_cbits/MemoryManagement.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/MemoryManagement.m (original)
+++ branches/objc2/hoc/HOC_cbits/MemoryManagement.m Fri Jan 9 16:57:06 2009
@@ -1,3 +1,11 @@
+#ifdef GNUSTEP
+#include <objc/objc-api.h>
+#else
+#include <objc/objc-runtime.h>
+#endif
+
+#include <stdlib.h>
+
#include "MemoryManagement.h"
#define DO_LOG 0
@@ -44,6 +52,7 @@
static SEL selRetain = 0;
static SEL selRelease = 0;
+static SEL selRetainCount = 0;
static SEL selDealloc = 0;
static SEL selAutorelease = 0;
static SEL selAlloc = 0;
@@ -55,7 +64,7 @@
if(!selRetain)
selRetain = getSelectorForName("retain");
#if DO_LOG
- printf("retain %p, %p\n",obj,obj->class_pointer);
+ printf("retain %p, %p\n",obj,obj->isa);
#endif
objc_msgSend(obj,selRetain);
}
@@ -65,9 +74,59 @@
if(!selRelease)
selRelease = getSelectorForName("release");
#if DO_LOG
- printf("release %p, %p\n",obj,obj->class_pointer);
+ printf("release %p, %p\n",obj,obj->isa);
#endif
objc_msgSend(obj,selRelease);
+}
+
+void retainSuper(id obj, Class cls)
+{
+ if(!selRetain)
+ selRetain = getSelectorForName("retain");
+
+#if DO_LOG
+ printf("retain super %p, %p\n",obj,cls);
+#endif
+
+ struct objc_super * super = calloc(1, sizeof(struct objc_super));
+
+ super->receiver = obj;
+ super->super_class = cls;
+
+ objc_msgSendSuper(super, selRetain);
+}
+
+void releaseSuper(id obj, Class cls)
+{
+ if(!selRelease)
+ selRelease = getSelectorForName("release");
+
+#if DO_LOG
+ printf("release super %p, %p\n",obj,cls);
+#endif
+
+ struct objc_super * super = calloc(1, sizeof(struct objc_super));
+
+ super->receiver = obj;
+ super->super_class = cls;
+
+ objc_msgSendSuper(super, selRelease);
+}
+
+unsigned int retainCount(id obj) {
+ unsigned int rc;
+
+#if DO_LOG
+ printf("retainCount %p = ",obj);
+#endif
+ if(!selRetainCount)
+ selRetainCount = getSelectorForName("retainCount");
+
+ rc = (unsigned int) objc_msgSend(obj,selRetainCount);
+#if DO_LOG
+ printf("%d\n",rc);
+#endif
+ return rc;
}
void deallocObject(id obj)
|
|
From: <cod...@go...> - 2008-12-29 17:34:16
|
Author: jam...@us...
Date: Mon Dec 29 09:33:01 2008
New Revision: 379
Modified:
/ (props changed)
trunk/hoc/HOC.cabal
Log:
Placed 'c-sources' line back into cabal file. I thought this had fixed
ghc-6.10 builds, but it turns out the problem was deeper than I thought.
Essentially, this line was fooling Cabal into including
dist/build/HOC_cbits.o in the built library. Under earlier versions of
GHC, the ghc call that the cabal generates to handle this "C source" is
silently ignored because it is calling 'ghc -c' on an object file. With
ghc 6.10.1, the call dies violently with "no input files".
I have dug around a bit in the cabal api, but not yet found any way of
achieving the desired effect, so for now I'm going to have to re-open issue
10 and put the line back.
Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal (original)
+++ trunk/hoc/HOC.cabal Mon Dec 29 09:33:01 2008
@@ -57,6 +57,7 @@
hs-source-dirs: HOC
extra-libraries: objc, ffi
+ c-sources: HOC_cbits.o
if os(darwin)
include-dirs: /usr/include/ffi
frameworks: Foundation
|
|
From: <cod...@go...> - 2008-12-29 16:15:52
|
Author: jam...@us...
Date: Mon Dec 29 07:46:35 2008
New Revision: 378
Modified:
/ (props changed)
trunk/hoc/HOC.cabal
trunk/hoc/HOC/HOC/Exception.hs
trunk/hoc/InterfaceGenerator2/Headers.hs
trunk/hoc/InterfaceGenerator2/ParserBase.hs
Log:
Updated to build with ghc 6.10.1 (Issue 10)
Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal (original)
+++ trunk/hoc/HOC.cabal Mon Dec 29 07:46:35 2008
@@ -18,7 +18,7 @@
description: build for Objective-C 2.0
Library
- build-depends: base, template-haskell, unix
+ build-depends: base < 4, template-haskell, unix
exposed-modules:
HOC,
@@ -57,7 +57,6 @@
hs-source-dirs: HOC
extra-libraries: objc, ffi
- c-sources: HOC_cbits.o
if os(darwin)
include-dirs: /usr/include/ffi
frameworks: Foundation
Modified: trunk/hoc/HOC/HOC/Exception.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Exception.hs (original)
+++ trunk/hoc/HOC/HOC/Exception.hs Mon Dec 29 07:46:35 2008
@@ -5,7 +5,7 @@
import Foreign
import Foreign.C.String ( CString, withCString )
import Prelude hiding ( catch )
-import Control.Exception ( evaluate, throwIO, throwDyn, catchDyn, catch
)
+import Control.Exception ( Exception, evaluate, throwIO, throwDyn,
catchDyn, catch )
import HOC.Base
import HOC.Arguments
@@ -15,8 +15,8 @@
deriving Typeable
-foreign import ccall unsafe wrapHaskellException :: CString -> StablePtr a
-> IO (Ptr ObjCObject)
-foreign import ccall unsafe unwrapHaskellException :: Ptr ObjCObject -> IO
(StablePtr a)
+foreign import ccall unsafe wrapHaskellException :: CString -> StablePtr
Exception -> IO (Ptr ObjCObject)
+foreign import ccall unsafe unwrapHaskellException :: Ptr ObjCObject -> IO
(StablePtr Exception)
exceptionObjCToHaskell :: Ptr ObjCObject -> IO a
Modified: trunk/hoc/InterfaceGenerator2/Headers.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Headers.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Headers.hs Mon Dec 29 07:46:35 2008
@@ -12,7 +12,7 @@
import Control.Monad(when)
import Data.Char(isAlphaNum, toUpper)
import Data.List(isPrefixOf,isSuffixOf)
-import Data.Maybe(mapMaybe)
+import Data.Maybe(mapMaybe, maybeToList)
import System.Directory(getDirectoryContents, doesDirectoryExist)
import System.Info(os)
import Text.Parsec( runParserT )
@@ -89,9 +89,9 @@
graph :: Gr () ()
graph = mkUGraph [ 0 .. length loaded - 1 ]
[ (to, from) | (_, name, includes, _) <- loaded,
- from <- Map.lookup name
namesToNums,
+ from <- maybeToList $ Map.lookup
name namesToNums,
include <- includes,
- to <- Map.lookup include
namesToNums ]
+ to <- maybeToList $ Map.lookup
include namesToNums ]
sorted = map (numsToHeaders Map.!) $ topsort graph
process ( (headerFileName, moduleName, imports, contents) :
moreHeaders ) env accum
Modified: trunk/hoc/InterfaceGenerator2/ParserBase.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ParserBase.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ParserBase.hs Mon Dec 29 07:46:35 2008
@@ -21,7 +21,13 @@
= fst $ runMessages $ runParserT parser emptyParseEnvironment fileName
text
lookupIntegerConstant :: String -> Parser Integer
-lookupIntegerConstant name = getState >>= Map.lookup name
+lookupIntegerConstant name = getState >>= mapLookup name
+ where
+ -- ghc 6.10's containers package no longer allows arbitrary
+ -- monads in its return types
+ mapLookup k v = case Map.lookup k v of
+ Nothing -> fail "Integer constant not found"
+ Just x -> return x
defineIntegerConstant :: String -> Integer -> Parser ()
defineIntegerConstant name value = modifyState (Map.insert name value)
|
|
From: <cod...@go...> - 2008-12-21 22:06:32
|
Author: wol...@gm...
Date: Sun Dec 21 13:42:00 2008
New Revision: 377
Added:
trunk/hoc/HOC_cbits/Ivars.h (contents, props changed)
trunk/hoc/HOC_cbits/Ivars.m
trunk/hoc/HOC_cbits/Methods.h (contents, props changed)
trunk/hoc/HOC_cbits/Methods.m
Modified:
trunk/hoc/HOC.cabal
trunk/hoc/HOC/HOC.hs
trunk/hoc/HOC/HOC/Base.hs
trunk/hoc/HOC/HOC/Class.hs
trunk/hoc/HOC/HOC/DeclareClass.hs
trunk/hoc/HOC/HOC/ExportClass.hs
trunk/hoc/HOC/HOC/NewClass.hs
trunk/hoc/HOC_cbits/Class.h
trunk/hoc/HOC_cbits/Class.m
trunk/hoc/HOC_cbits/Exceptions.m
trunk/hoc/HOC_cbits/GetNewHaskellData.m
trunk/hoc/HOC_cbits/NewClass.h
trunk/hoc/HOC_cbits/NewClass.m
trunk/hoc/InterfaceGenerator2/Output.hs
trunk/hoc/Setup.hs
trunk/hoc/Tests/TestFoundation.hs
Log:
Merge Objective-C 2.0 branch
Big thanks to James Cook for doing all the work.
Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal (original)
+++ trunk/hoc/HOC.cabal Sun Dec 21 13:42:00 2008
@@ -14,6 +14,9 @@
description: build test cases
default: False
+Flag ObjC2
+ description: build for Objective-C 2.0
+
Library
build-depends: base, template-haskell, unix
@@ -54,13 +57,18 @@
hs-source-dirs: HOC
extra-libraries: objc, ffi
+ c-sources: HOC_cbits.o
if os(darwin)
+ include-dirs: /usr/include/ffi
frameworks: Foundation
cpp-options: -DMACOSX
else
-- paths are inserted by Setup.hs
extra-libraries: gnustep-base
cpp-options: -DGNUSTEP
+
+ if flag(ObjC2)
+ cpp-options: -D__OBJC2__=1
Executable hoc-ifgen
Modified: trunk/hoc/HOC/HOC.hs
==============================================================================
--- trunk/hoc/HOC/HOC.hs (original)
+++ trunk/hoc/HOC/HOC.hs Sun Dec 21 13:42:00 2008
@@ -4,6 +4,7 @@
nil,
Object(..),
Class,
+ MetaClass,
ClassAndObject,
ClassObject,
classObject,
Modified: trunk/hoc/HOC/HOC/Base.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Base.hs (original)
+++ trunk/hoc/HOC/HOC/Base.hs Sun Dec 21 13:42:00 2008
@@ -20,6 +20,10 @@
--
+foreign import ccall "stdlib.h &free"
+ freePtr :: FunPtr (Ptr a -> IO ())
+
+--
foreign import ccall "MemoryManagement.h retainObject"
retainObject :: Ptr ObjCObject -> IO ()
Modified: trunk/hoc/HOC/HOC/Class.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Class.hs (original)
+++ trunk/hoc/HOC/HOC/Class.hs Sun Dec 21 13:42:00 2008
@@ -11,15 +11,13 @@
import Foreign
import Foreign.C.String
-
data Class_ a
type Class a = ID (Class_ a)
-
+type MetaClass a = Class (Class_ a)
unsafeGetClassObject :: String -> Class a
-
foreign import ccall unsafe "Class.h getClassByName"
c_getClassByName :: CString -> IO (Ptr ObjCObject)
@@ -30,6 +28,16 @@
getClassByName name >>= importImmortal
+unsafeGetMetaclassForClass :: Class a -> MetaClass a
+
+foreign import ccall unsafe "Class.h getClassForObject"
+ c_getClassForObject :: Ptr ObjCObject -> IO (Ptr ObjCObject)
+
+getClassForObject obj = withExportedArgument obj c_getClassForObject
+
+{-# NOINLINE unsafeGetMetaclassForClass #-}
+unsafeGetMetaclassForClass obj = unsafePerformIO $
+ getClassForObject obj >>= importImmortal
class (Object a, Object b) => ClassAndObject a b | a -> b, b -> a
Modified: trunk/hoc/HOC/HOC/DeclareClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/DeclareClass.hs (original)
+++ trunk/hoc/HOC/HOC/DeclareClass.hs Sun Dec 21 13:42:00 2008
@@ -31,6 +31,12 @@
`appT` (conT (mkName phantomName)
`appT` varT (mkName "a"))),
+ -- type $(metaMetaClassName) a = $(superMetaMetaClassName)
($(phantomName) a)
+ tySynD (mkName metaMetaClassName) [mkName "a"]
+ (conT (mkName superMetaMetaClassName)
+ `appT` (conT (mkName phantomName)
+ `appT` varT (mkName "a"))),
+
-- $(classObjectName) :: $(metaClassName) ()
sigD (mkName classObjectName) (conT (mkName metaClassName)
`appT` [t| () |]),
@@ -39,6 +45,11 @@
valD (return $ VarP (mkName classObjectName))
(normalB [| unsafeGetClassObject $(stringE name) |]) [],
+ -- $(metaClassObjectName) = unsafeGetMetaclassForClass
$(classObjectName)
+ valD (return $ VarP (mkName metaClassObjectName))
+ (normalB [| unsafeGetMetaclassForClass $(varE (mkName
classObjectName)) |]) [],
+
+ -- $(superName) :: String
sigD (mkName superName) [t| String |],
-- $(superName) = "super"
@@ -47,20 +58,35 @@
-- instance SuperClass (name ()) (super ())
instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`
superType) [],
+ -- instance SuperClass (clsName ()) (superClsName ())
+ instanceD (cxt []) (conT ''SuperClass `appT` metaClsType `appT`
superMetaType) [],
+
-- instance ClassObject (metaClsName ())
-- where classObject = classObject
instanceD (cxt []) (conT ''ClassObject `appT` metaClsType)
- [funD 'classObject [clause [] (normalB $ varE (mkName
classObjectName)) []]]
+ [funD 'classObject [clause [] (normalB $ varE (mkName
classObjectName)) []]],
+
+ -- instance ClassObject metaMetaCls
+ -- where classObject = unsafeGetMetaclassForClass classObject
+ -- {- metaclass object, to support super calls in class methods -}
+ instanceD (cxt []) (conT ''ClassObject `appT` metaMetaClsType)
+ [funD 'classObject [clause [] (normalB $ varE (mkName
metaClassObjectName)) []]]
]
where
phantomName = name ++ "_"
metaClassName = name ++ "Class"
+ metaMetaClassName = name ++ "MetaClass"
metaPhantomName = metaClassName ++ "_"
superMetaClassName | super == "ID" = "Class"
| otherwise = super ++ "Class"
+ superMetaMetaClassName | super == "ID" = "MetaClass"
+ | otherwise = super ++ "MetaClass"
classObjectName = "_" ++ name
+ metaClassObjectName = "_" ++ metaClassName
superName = "super_" ++ name
+ metaMetaClsType = conT (mkName metaMetaClassName) `appT` [t| () |]
metaClsType = conT (mkName metaClassName) `appT` [t| () |]
clsType = conT (mkName name) `appT` [t| () |]
superType = conT (mkName super) `appT` [t| () |]
+ superMetaType = conT (mkName superMetaClassName) `appT` [t| () |]
Modified: trunk/hoc/HOC/HOC/ExportClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/ExportClass.hs (original)
+++ trunk/hoc/HOC/HOC/ExportClass.hs Sun Dec 21 13:42:00 2008
@@ -138,7 +138,7 @@
$(fillMethodList False 3 [|imethods|] instanceMethods)
$(fillMethodList True 0 [|cmethods|] classMethods)
clsname <- newCString name
- newClass super clsname defaultIvarSize ivars imethods
cmethods
+ newClass super clsname ivars imethods cmethods
|]
where
typedInitIvars = [|initializeInstanceVariables|]
Modified: trunk/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/NewClass.hs (original)
+++ trunk/hoc/HOC/HOC/NewClass.hs Sun Dec 21 13:42:00 2008
@@ -9,7 +9,6 @@
setIvarInList,
setMethodInList,
makeDefaultIvarList,
- defaultIvarSize,
setHaskellRetainMethod,
setHaskellReleaseMethod,
setHaskellDataMethod
@@ -22,49 +21,79 @@
import HOC.Class
import Foreign.C.String
+import Foreign.C.Types
import Foreign
type IMP = FFICif -> Ptr () -> Ptr (Ptr ()) -> IO (Ptr ObjCObject)
foreign import ccall "wrapper" wrapIMP :: IMP -> IO (FunPtr IMP)
-newtype MethodList = MethodList (Ptr MethodList)
-newtype IvarList = IvarList (Ptr IvarList)
+newtype MethodList = MethodList (ForeignPtr MethodList)
+newtype IvarList = IvarList (ForeignPtr IvarList)
foreign import ccall "NewClass.h newClass"
- newClass :: Ptr ObjCObject -> CString
- -> Int -> IvarList
+ rawNewClass :: Ptr ObjCObject -> CString
+ -> Ptr IvarList
+ -> Ptr MethodList -> Ptr MethodList
+ -> IO ()
+
+newClass :: Ptr ObjCObject -> CString
+ -> IvarList
-> MethodList -> MethodList
-> IO ()
+newClass sc name (IvarList ivars) (MethodList ms) (MethodList cms) =
+ withForeignPtr ivars $ \ivars ->
+ withForeignPtr ms $ \ms ->
+ withForeignPtr cms $ \cms -> do
+ rawNewClass sc name ivars ms cms
foreign import ccall "NewClass.h makeMethodList"
- makeMethodList :: Int -> IO MethodList
+ rawMakeMethodList :: Int -> IO (Ptr MethodList)
foreign import ccall "NewClass.h setMethodInList"
- rawSetMethodInList :: MethodList -> Int
+ rawSetMethodInList :: Ptr MethodList -> Int
-> SEL -> CString
-> FFICif -> FunPtr IMP
-> IO ()
foreign import ccall "NewClass.h makeIvarList"
- makeIvarList :: Int -> IO IvarList
+ rawMakeIvarList :: Int -> IO (Ptr IvarList)
foreign import ccall "NewClass.h setIvarInList"
- setIvarInList :: IvarList -> Int
- -> CString -> CString -> Int -> IO ()
+ rawSetIvarInList :: Ptr IvarList -> Int
+ -> CString -> CString -> CSize -> Word8 -> IO ()
-setMethodInList methodList idx sel typ cif imp = do
- typC <- newCString typ
- thunk <- wrapIMP imp
- rawSetMethodInList methodList idx sel typC cif thunk
+makeIvarList :: Int -> IO IvarList
+makeIvarList n = do
+ ivars <- rawMakeIvarList n
+ ivars <- newForeignPtr freePtr ivars
+ return (IvarList ivars)
+
+setIvarInList:: IvarList -> Int
+ -> CString -> CString -> CSize -> Word8 -> IO ()
+setIvarInList (IvarList ivars) n name ty sz align =
+ withForeignPtr ivars $ \ivars -> do
+ rawSetIvarInList ivars n name ty sz align
+
+makeMethodList :: Int -> IO MethodList
+makeMethodList n = do
+ methods <- rawMakeMethodList n
+ methods <- newForeignPtr freePtr methods
+ return (MethodList methods)
+
+setMethodInList (MethodList methodList) idx sel typ cif imp =
+ withForeignPtr methodList $ \methodList -> do
+ typC <- newCString typ
+ thunk <- wrapIMP imp
+ rawSetMethodInList methodList idx sel typC cif thunk
makeDefaultIvarList = do
list <- makeIvarList 1
name <- newCString "__retained_haskell_part__"
typ <- newCString "^v"
- setIvarInList list 0 name typ 0
+ setIvarInList list 0 name typ
+ (fromIntegral $ sizeOf nullPtr)
+ (fromIntegral $ alignment nullPtr)
return list
-defaultIvarSize = 4 :: Int
-
retainSelector = getSelectorForName "retain"
retainCif = getCifForSelector (undefined :: ID () -> IO (ID ()))
@@ -75,33 +104,11 @@
getHaskellDataCif = getCifForSelector (undefined :: Class () -> ID () ->
IO (ID ()))
-- actually -> IO (Ptr
()) ...
-setHaskellRetainMethod methodList idx = do
- typC <- newCString "@@:"
- thunk <- wrapIMP haskellObject_retain_IMP
- rawSetMethodInList methodList
- idx
- retainSelector
- typC
- retainCif
- thunk
+setHaskellRetainMethod methodList idx =
+ setMethodInList methodList idx retainSelector "@@:" retainCif
haskellObject_retain_IMP
-setHaskellReleaseMethod methodList idx = do
- typC <- newCString "v@:"
- thunk <- wrapIMP haskellObject_release_IMP
- rawSetMethodInList methodList
- idx
- releaseSelector
- typC
- releaseCif
- thunk
-
-setHaskellDataMethod methodList idx super mbDat = do
- typC <- newCString "^v@:#"
- thunk <- wrapIMP (getHaskellData_IMP super mbDat)
- rawSetMethodInList methodList
- idx
- getHaskellDataSelector
- typC
- getHaskellDataCif
- thunk
+setHaskellReleaseMethod methodList idx =
+ setMethodInList methodList idx releaseSelector "v@:" releaseCif
haskellObject_release_IMP
+setHaskellDataMethod methodList idx super mbDat =
+ setMethodInList methodList idx getHaskellDataSelector "^v@:#"
getHaskellDataCif (getHaskellData_IMP super mbDat)
Modified: trunk/hoc/HOC_cbits/Class.h
==============================================================================
--- trunk/hoc/HOC_cbits/Class.h (original)
+++ trunk/hoc/HOC_cbits/Class.h Sun Dec 21 13:42:00 2008
@@ -1,3 +1,9 @@
#include <objc/objc.h>
id getClassByName(const char* name);
+
+Class getSuperclassForClass(Class class);
+Class getRootClassForClass(Class super_class);
+
+Class getClassForObject(id self);
+Class getSuperClassForObject(id self);
\ No newline at end of file
Modified: trunk/hoc/HOC_cbits/Class.m
==============================================================================
--- trunk/hoc/HOC_cbits/Class.m (original)
+++ trunk/hoc/HOC_cbits/Class.m Sun Dec 21 13:42:00 2008
@@ -13,3 +13,50 @@
return objc_getClass(name);
#endif
}
+
+Class getSuperclassForClass(Class class)
+{
+#ifdef GNUSTEP
+ if(CLS_ISRESOLV(class))
+ return class->super_class;
+ else
+ return getClassByName((const char*) class->super_class);
+
+#elif defined(__OBJC2__)
+ return class_getSuperclass(class);
+#else
+ return class->super_class;
+#endif
+}
+
+Class getRootClassForClass(Class super_class)
+{
+ Class root_class;
+
+ for(root_class = super_class;
+ getSuperclassForClass(root_class) != nil;
+ root_class = getSuperclassForClass(root_class))
+ ;
+
+ return root_class;
+}
+
+Class getClassForObject(id object)
+{
+#ifdef __OBJC2__
+ return object_getClass(object);
+#else
+ return object->isa;
+#endif
+}
+
+Class getSuperClassForObject(id self)
+{
+#ifdef GNUSTEP
+ return self->class_pointer->super_class;
+#elif defined(__OBJC2__)
+ return class_getSuperclass(object_getClass(self));
+#else
+ return self->isa->super_class;
+#endif
+}
\ No newline at end of file
Modified: trunk/hoc/HOC_cbits/Exceptions.m
==============================================================================
--- trunk/hoc/HOC_cbits/Exceptions.m (original)
+++ trunk/hoc/HOC_cbits/Exceptions.m Sun Dec 21 13:42:00 2008
@@ -1,10 +1,15 @@
#include <objc/objc.h>
#include "NewClass.h"
#include "Class.h"
+#include "Ivars.h"
+#include "Methods.h"
#include "Selector.h"
#include "Marshalling.h"
#include "HsFFI.h"
+#define hsExceptionClassName "HOCHaskellException"
+#define hsExceptionIvarName "_haskellException"
+
static BOOL excWrapperInited = NO;
static int stablePtrOffset;
static id clsHOCHaskellException;
@@ -21,12 +26,18 @@
#if GNUSTEP
super.self = self;
- super.class = self->class_pointer->super_class;
+ super.class = getSuperClassForObject(self);
(*objc_msg_lookup_super(&super, selDealloc))(self, selDealloc);
#else
super.receiver = self;
- super.class = self->isa->super_class;
+
+# ifdef __OBJC2__
+ super.super_class = getSuperClassForObject(self);
+# else
+ super.class = getSuperClassForObject(self);
+# endif
+
objc_msgSendSuper(&super, selDealloc);
#endif
}
@@ -35,30 +46,29 @@
{
if(!excWrapperInited)
{
- struct objc_method_list *methods = makeMethodList(1);
- struct objc_method_list *class_methods = makeMethodList(0);
- struct objc_ivar_list *ivars = makeIvarList(1);
+ struct hoc_method_list *methods = makeMethodList(1);
+ struct hoc_method_list *class_methods = makeMethodList(0);
+ struct hoc_ivar_list *ivars = makeIvarList(1);
+ struct objc_ivar *stablePtrIvar;
selDealloc = getSelectorForName("dealloc");
-#ifdef GNUSTEP
- methods->method_list[0].method_name = (SEL)"dealloc";
-#else
- methods->method_list[0].method_name = selDealloc;
-#endif
- methods->method_list[0].method_types = "v@:";
- methods->method_list[0].method_imp = (IMP) &exc_dealloc;
+ setMethodInListWithIMP(methods, 0, selDealloc, "v@:", (IMP)
&exc_dealloc);
- setIvarInList(ivars, 0, "_haskellExecption", "^v", 0);
+ setIvarInList(ivars, 0, hsExceptionIvarName, "^v", sizeof(void *),
IVAR_PTR_ALIGN);
newClass(getClassByName("NSException"),
- "HOCHaskellException",
- sizeof(void*),
+ hsExceptionClassName,
ivars, methods, class_methods);
clsHOCHaskellException = getClassByName("HOCHaskellException");
- stablePtrOffset = ivars->ivar_list[0].ivar_offset;
+ stablePtrIvar = class_getInstanceVariable(clsHOCHaskellException,
hsExceptionIvarName);
+#ifdef __OBJC2__
+ stablePtrOffset = ivar_getOffset(stablePtrIvar);
+#else
+ stablePtrOffset = stablePtrIvar->ivar_offset;
+#endif
selExceptionWithNameReasonUserInfo =
getSelectorForName("exceptionWithName:reason:userInfo:");
Modified: trunk/hoc/HOC_cbits/GetNewHaskellData.m
==============================================================================
--- trunk/hoc/HOC_cbits/GetNewHaskellData.m (original)
+++ trunk/hoc/HOC_cbits/GetNewHaskellData.m Sun Dec 21 13:42:00 2008
@@ -47,7 +47,13 @@
#endif
if(m)
+ {
+#ifdef __OBJC2__
+ imp = method_getImplementation(m);
+#else
imp = m->method_imp;
+#endif
+ }
if(imp)
return (*(getHaskellDataIMP)imp)(obj, selGetHaskellData);
Added: trunk/hoc/HOC_cbits/Ivars.h
==============================================================================
--- (empty file)
+++ trunk/hoc/HOC_cbits/Ivars.h Sun Dec 21 13:42:00 2008
@@ -0,0 +1,39 @@
+#include <stdlib.h>
+#include <stdint.h>
+
+struct hoc_ivar {
+ char *ivar_name;
+ char *ivar_types;
+ size_t ivar_size;
+ uint8_t ivar_alignment;
+};
+
+#define IVAR_PTR_ALIGN ((uint8_t) sizeof(void *))
+
+struct hoc_ivar_list {
+ int ivar_count;
+
+ /* variable length structure */
+ struct hoc_ivar ivar_list[1];
+};
+
+struct hoc_ivar_list * makeIvarList(int n);
+
+void setIvarInList(
+ struct hoc_ivar_list *list,
+ int i,
+ char *name, /* never deallocate this */
+ char *types, /* never deallocate this */
+ size_t size,
+ uint8_t alignment
+ );
+
+#ifndef __OBJC2__
+
+struct objc_ivar_list * buildIndexedIvarList(
+ struct hoc_ivar_list *list,
+ int start_offset,
+ int *instance_size /* out */
+ );
+
+#endif
\ No newline at end of file
Added: trunk/hoc/HOC_cbits/Ivars.m
==============================================================================
--- (empty file)
+++ trunk/hoc/HOC_cbits/Ivars.m Sun Dec 21 13:42:00 2008
@@ -0,0 +1,92 @@
+#ifdef GNUSTEP
+#include <objc/objc-api.h>
+#else
+#include <objc/objc-runtime.h>
+#endif
+
+#include <stdlib.h>
+#include <assert.h>
+
+#include "Ivars.h"
+
+struct hoc_ivar_list * makeIvarList(int n)
+{
+ struct hoc_ivar_list *list =
+ calloc(1, sizeof(struct hoc_ivar_list)
+ + (n-1) * sizeof(struct hoc_ivar));
+ list->ivar_count = n;
+ return list;
+}
+
+void setIvarInList(
+ struct hoc_ivar_list *list,
+ int i,
+ char *name,
+ char *types,
+ size_t size,
+ uint8_t alignment
+ )
+{
+ list->ivar_list[i].ivar_name = name;
+ list->ivar_list[i].ivar_types = types;
+ list->ivar_list[i].ivar_size = size;
+ list->ivar_list[i].ivar_alignment = alignment;
+}
+
+#ifndef __OBJC2__
+
+/* Used to be makeIvarList in NewClass.m */
+static struct objc_ivar_list * makeIndexedIvarList(int n)
+{
+ struct objc_ivar_list *list =
+ calloc(1, sizeof(struct objc_ivar_list)
+ + (n-1) * sizeof(struct objc_ivar));
+ list->ivar_count = n;
+ return list;
+}
+
+/* Used to be setIvarInList in NewClass.m */
+static void setIvarInIndexedList(
+ struct objc_ivar_list *list,
+ int i,
+ char *name,
+ char *type,
+ int offset
+ )
+{
+ list->ivar_list[i].ivar_name = name;
+ list->ivar_list[i].ivar_type = type;
+ list->ivar_list[i].ivar_offset = offset;
+}
+
+struct objc_ivar_list * buildIndexedIvarList(
+ struct hoc_ivar_list *list,
+ int start_offset,
+ int *instance_size /* out */
+ )
+{
+ struct objc_ivar_list * outList =
makeIndexedIvarList(list->ivar_count);
+ int offset = start_offset;
+ int i;
+
+ for (i = 0; i < list->ivar_count; i++)
+ {
+ struct hoc_ivar *ivar = &list->ivar_list[i];
+
+ int align = ivar->ivar_alignment;
+ int alignmask = align - 1;
+
+ assert((align & alignmask) == 0);
+ if ((offset & alignmask) != 0)
+ offset = (offset & ~alignmask) + align;
+
+ setIvarInIndexedList(outList, i, ivar->ivar_name,
ivar->ivar_types, offset);
+
+ offset += ivar->ivar_size;
+ }
+
+ *instance_size = offset - start_offset;
+ return outList;
+}
+
+#endif // ifndef __OBJC2__
\ No newline at end of file
Added: trunk/hoc/HOC_cbits/Methods.h
==============================================================================
--- (empty file)
+++ trunk/hoc/HOC_cbits/Methods.h Sun Dec 21 13:42:00 2008
@@ -0,0 +1,57 @@
+#ifdef GNUSTEP
+#include <objc/objc-api.h>
+#else
+#include <objc/objc-runtime.h>
+#endif
+
+#include <ffi.h>
+
+#ifdef __OBJC__
+@class NSException;
+#else
+typedef void NSException;
+#endif
+
+typedef NSException *(*haskellIMP)(
+ ffi_cif *cif,
+ void * ret,
+ void **args
+ );
+
+struct hoc_method {
+ SEL method_name;
+ char *method_types;
+ IMP method_imp;
+};
+
+struct hoc_method_list {
+ int method_count;
+
+ /* variable length structure */
+ struct hoc_method method_list[1];
+};
+
+struct hoc_method_list * makeMethodList(int n);
+
+void setMethodInListWithIMP(
+ struct hoc_method_list *list,
+ int i,
+ SEL sel,
+ char *types, /* never deallocate this */
+ IMP imp /* never deallocate this */
+ );
+
+void setMethodInList(
+ struct hoc_method_list *list,
+ int i,
+ SEL sel,
+ char *types, /* never deallocate this */
+ ffi_cif *cif, /* never deallocate this */
+ haskellIMP imp
+ );
+
+#ifndef __OBJC2__
+
+struct objc_method_list * convertMethodList(struct hoc_method_list * list);
+
+#endif
\ No newline at end of file
Added: trunk/hoc/HOC_cbits/Methods.m
==============================================================================
--- (empty file)
+++ trunk/hoc/HOC_cbits/Methods.m Sun Dec 21 13:42:00 2008
@@ -0,0 +1,104 @@
+#include <stdlib.h>
+#include "Methods.h"
+#include "Statistics.h"
+
+#ifdef __OBJC__
+#import <Foundation/NSException.h>
+#endif
+
+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];
+}
+
+static ffi_closure *newIMP(ffi_cif *cif, haskellIMP imp)
+{
+ ffi_closure *closure = (ffi_closure*) calloc(1, sizeof(ffi_closure));
+ ffi_prep_closure(closure, cif, &objcIMP, (void*) imp);
+ return closure;
+}
+
+struct hoc_method_list * makeMethodList(int n)
+{
+ struct hoc_method_list *list =
+ calloc(1, sizeof(struct hoc_method_list)
+ + (n-1) * sizeof(struct hoc_method));
+ list->method_count = n;
+ return list;
+}
+
+void setMethodInList(
+ struct hoc_method_list *list,
+ int i,
+ SEL sel,
+ char *types,
+ ffi_cif *cif,
+ haskellIMP imp
+ )
+{
+ setMethodInListWithIMP(list, i, sel, types, (IMP) newIMP(cif, imp) );
+}
+
+void setMethodInListWithIMP(
+ struct hoc_method_list *list,
+ int i,
+ SEL sel,
+ char *types,
+ IMP imp
+ )
+{
+ list->method_list[i].method_name = sel;
+ list->method_list[i].method_types = types;
+ list->method_list[i].method_imp = imp;
+}
+
+#ifndef __OBJC2__
+
+/* Was previously makeMethodList */
+static struct objc_method_list * makeObjcMethodList(int n)
+{
+ struct objc_method_list *list =
+ calloc(1, sizeof(struct objc_method_list)
+ + (n-1) * sizeof(struct objc_method));
+ list->method_count = n;
+ return list;
+}
+
+/* Was previously setMethodInList */
+static void setObjCMethodInList(
+ struct objc_method_list *list,
+ int i,
+ SEL sel,
+ char *types,
+ IMP imp
+ )
+{
+#ifdef GNUSTEP
+ list->method_list[i].method_name = (SEL) sel_get_name(sel);
+#else
+ list->method_list[i].method_name = sel;
+#endif
+ list->method_list[i].method_types = types;
+ list->method_list[i].method_imp = imp;
+}
+
+struct objc_method_list *
+convertMethodList(struct hoc_method_list * list) {
+ struct objc_method_list * newList =
makeObjcMethodList(list->method_count);
+ int i;
+
+ for(i = 0; i < list->method_count; i++)
+ {
+ struct hoc_method * method = &list->method_list[i];
+
+ setObjCMethodInList(newList, i, method->method_name,
method->method_types, method->method_imp);
+ }
+
+ return newList;
+}
+
+#endif // ifndef __OBJC2__
\ No newline at end of file
Modified: trunk/hoc/HOC_cbits/NewClass.h
==============================================================================
--- trunk/hoc/HOC_cbits/NewClass.h (original)
+++ trunk/hoc/HOC_cbits/NewClass.h Sun Dec 21 13:42:00 2008
@@ -4,42 +4,12 @@
#include <objc/objc-runtime.h>
#endif
-#include <ffi.h>
+struct hoc_ivar_list;
+struct hoc_method_list;
-#ifdef __OBJC__
-@class NSException;
-#else
-typedef void NSException;
-#endif
-
-void newClass(struct objc_class * super_class,
+void newClass(Class super_class,
const char * name, /* never
deallocate this */
- int instance_size,
- struct objc_ivar_list *ivars, /* never deallocate this */
- struct objc_method_list *methods, /* never deallocate this */
- struct objc_method_list *class_methods); /* never deallocate this */
+ struct hoc_ivar_list *ivars,
+ struct hoc_method_list *methods,
+ struct hoc_method_list *class_methods);
-typedef NSException *(*haskellIMP)(
- ffi_cif *cif,
- void * ret,
- void **args
- );
-
-struct objc_method_list * makeMethodList(int n);
-void setMethodInList(
- struct objc_method_list *list,
- int i,
- SEL sel,
- char *types, /* never deallocate this */
- ffi_cif *cif, /* never deallocate this */
- haskellIMP imp
- );
-
-struct objc_ivar_list * makeIvarList(int n);
-void setIvarInList(
- struct objc_ivar_list *list,
- int i,
- char *name, /* never deallocate this */
- char *type, /* never deallocate this */
- int offset
- );
Modified: trunk/hoc/HOC_cbits/NewClass.m
==============================================================================
--- trunk/hoc/HOC_cbits/NewClass.m (original)
+++ trunk/hoc/HOC_cbits/NewClass.m Sun Dec 21 13:42:00 2008
@@ -2,8 +2,9 @@
#include <Foundation/NSException.h>
#include <assert.h>
#include "Class.h"
+#include "Ivars.h"
+#include "Methods.h"
#include "NewClass.h"
-#include "Statistics.h"
#ifdef GNUSTEP
#define isa class_pointer
@@ -11,157 +12,133 @@
#define CLS_META _CLS_META
#endif
-static struct objc_class * getSuper(struct objc_class *class)
-{
-#ifdef GNUSTEP
- if(CLS_ISRESOLV(class))
- return class->super_class;
- else
- return getClassByName((const char*) class->super_class);
-
+static Class allocateClassPair(Class super_class, const char * name) {
+#ifdef __OBJC2__
+ return objc_allocateClassPair(super_class, name, 0);
#else
- return class->super_class;
+ Class new_class = calloc( 2, sizeof(struct objc_class) );
+ Class meta_class = &new_class[1];
+ Class root_class = getRootClassForClass(super_class);
+
+ new_class->isa = meta_class;
+ new_class->info = CLS_CLASS;
+ meta_class->info = CLS_META;
+
+ new_class->name = name;
+ meta_class->name = name;
+
+# ifdef GNUSTEP
+ new_class->super_class = (void*)(super_class->name);
+ meta_class->super_class = (void*)(super_class->isa->name);
+# else
+ new_class->super_class = super_class;
+ meta_class->super_class = super_class->isa;
+ meta_class->isa = (void *)root_class->isa;
+# endif
+
+ return new_class;
#endif
}
-void newClass(struct objc_class * super_class,
- const char * name,
- int instance_size,
- struct objc_ivar_list *ivars,
- struct objc_method_list *methods,
- struct objc_method_list *class_methods)
-{
- struct objc_class * meta_class;
- struct objc_class * new_class;
- struct objc_class * root_class;
- int i;
-
- assert(objc_lookUpClass(name) == nil);
-
- for(root_class = super_class;
- root_class->super_class != nil;
- root_class = getSuper(root_class))
- ;
-
- new_class = calloc( 2, sizeof(struct objc_class) );
- meta_class = &new_class[1];
-
- new_class->isa = meta_class;
- new_class->info = CLS_CLASS;
- meta_class->info = CLS_META;
-
- new_class->name = name;
- meta_class->name = name;
-
- new_class->instance_size = super_class->instance_size + instance_size;
- for(i=0; i<ivars->ivar_count; i++)
- ivars->ivar_list[i].ivar_offset += super_class->instance_size;
-
- new_class->ivars = ivars;
-
+static void registerClassPair(Class new_class) {
#ifdef GNUSTEP
- new_class->super_class = (void*)(super_class->name);
- meta_class->super_class = (void*)(super_class->isa->name);
-
- {
- Module_t module = calloc(1, sizeof(Module));
- Symtab_t symtab = calloc(1, sizeof(Symtab) + sizeof(void*) /* two
defs pointers */);
- extern void __objc_exec_class (Module_t module);
- extern void __objc_resolve_class_links ();
-
- module->version = 8;
- module->size = sizeof(Module);
- module->name = strdup(name);
- module->symtab = symtab;
- symtab->cls_def_cnt = 1;
- symtab->defs[0] = new_class;
- symtab->defs[1] = NULL;
-
- __objc_exec_class (module);
- __objc_resolve_class_links();
- }
+ Module_t module = calloc(1, sizeof(Module));
+ Symtab_t symtab = calloc(1, sizeof(Symtab) + sizeof(void*) /* two defs
pointers */);
+ extern void __objc_exec_class (Module_t module);
+ extern void __objc_resolve_class_links ();
+
+ module->version = 8;
+ module->size = sizeof(Module);
+ module->name = strdup(name);
+ module->symtab = symtab;
+ symtab->cls_def_cnt = 1;
+ symtab->defs[0] = new_class;
+ symtab->defs[1] = NULL;
- class_add_method_list(new_class, methods);
- class_add_method_list(meta_class, class_methods);
+ __objc_exec_class (module);
+ __objc_resolve_class_links();
+#elif defined(__OBJC2__)
+ objc_registerClassPair(new_class);
#else
- new_class->methodLists = calloc( 1, sizeof(struct objc_method_list *) );
- meta_class->methodLists = calloc( 1, sizeof(struct objc_method_list *) );
- new_class->methodLists[0] = (struct objc_method_list*) -1;
- meta_class->methodLists[0] = (struct objc_method_list*) -1;
-
- new_class->super_class = super_class;
- meta_class->super_class = super_class->isa;
- meta_class->isa = (void *)root_class->isa;
-
- objc_addClass( new_class );
-
- class_addMethods(new_class, methods);
- class_addMethods(meta_class, class_methods);
+ objc_addClass( new_class );
#endif
}
-
-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];
-}
-
-static ffi_closure *newIMP(ffi_cif *cif, haskellIMP imp)
+static void addIvarsToClass(Class new_class, struct hoc_ivar_list *ivars)
{
- ffi_closure *closure = (ffi_closure*) calloc(1, sizeof(ffi_closure));
- ffi_prep_closure(closure, cif, &objcIMP, (void*) imp);
- return closure;
-}
-
-struct objc_method_list * makeMethodList(int n)
-{
- struct objc_method_list *list =
- calloc(1, sizeof(struct objc_method_list)
- + (n-1) * sizeof(struct objc_method));
- list->method_count = n;
- return list;
+#ifdef __OBJC2__
+ int i;
+
+ for (i = 0; i < ivars->ivar_count; i++)
+ {
+ struct hoc_ivar *ivar = &ivars->ivar_list[i];
+ class_addIvar(new_class, ivar->ivar_name,
+ ivar->ivar_size, ivar->ivar_alignment, ivar->ivar_types);
+ }
+#else
+ Class super_class = getSuperclassForClass(new_class);
+
+ int instance_size;
+ new_class->ivars = buildIndexedIvarList(
+ ivars,
+ super_class->instance_size,
+ &instance_size);
+
+ new_class->instance_size = super_class->instance_size + instance_size;
+#endif
}
-void setMethodInList(
- struct objc_method_list *list,
- int i,
- SEL sel,
- char *types,
- ffi_cif *cif,
- haskellIMP imp
- )
+static void addMethodsToClass(Class new_class, struct hoc_method_list
*methods)
{
#ifdef GNUSTEP
- list->method_list[i].method_name = (SEL) sel_get_name(sel);
+ class_add_method_list(new_class, convertMethodList(methods));
+#elif defined(__OBJC2__)
+ int i;
+ for (i = 0; i < methods->method_count; i++)
+ {
+ struct hoc_method * m = &methods->method_list[i];
+ class_addMethod(new_class, m->method_name, m->method_imp,
m->method_types);
+ }
#else
- list->method_list[i].method_name = sel;
+ new_class->methodLists = calloc( 1, sizeof(struct objc_method_list *)
);
+ new_class->methodLists[0] = (struct objc_method_list*) -1;
+
+ class_addMethods(new_class, convertMethodList(methods));
#endif
- list->method_list[i].method_types = types;
- list->method_list[i].method_imp = (IMP) newIMP(cif, imp);
}
-struct objc_ivar_list * makeIvarList(int n)
+void newClass(Class super_class,
+ const char * name,
+ struct hoc_ivar_list *ivars,
+ struct hoc_method_list *methods,
+ struct hoc_method_list *class_methods)
{
- struct objc_ivar_list *list =
- calloc(1, sizeof(struct objc_ivar_list)
- + (n-1) * sizeof(struct objc_ivar));
- list->ivar_count = n;
- return list;
-}
+ Class meta_class;
+ Class new_class;
+
+ assert(objc_lookUpClass(name) == nil);
+
+ /* Allocate the class and metaclass */
+ new_class = allocateClassPair(super_class, name);
+ meta_class = getClassForObject(new_class);
+
+ /* Add instance variables to the class */
+ addIvarsToClass(new_class, ivars);
+
+ /* Add methods and class methods */
+ /* I don't know whether order actually matters here in the non-objc2
cases,
+ so I'm leaving it as it was. */
+#ifdef __OBJC2__
+ addMethodsToClass(new_class, methods);
+ addMethodsToClass(meta_class, class_methods);
+
+ registerClassPair(new_class);
+#else
+ registerClassPair(new_class);
+
+ addMethodsToClass(new_class, methods);
+ addMethodsToClass(meta_class, class_methods);
+#endif
-void setIvarInList(
- struct objc_ivar_list *list,
- int i,
- char *name,
- char *type,
- int offset
- )
-{
- list->ivar_list[i].ivar_name = name;
- list->ivar_list[i].ivar_type = type;
- list->ivar_list[i].ivar_offset = offset;
}
+
Modified: trunk/hoc/InterfaceGenerator2/Output.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Output.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Output.hs Sun Dec 21 13:42:00 2008
@@ -25,6 +25,7 @@
ClassEntity _ ->
[eHaskellName e, '_' `BS.cons` eHaskellName e,
eHaskellName e `BS.append` BS.pack "Class",
+ eHaskellName e `BS.append` BS.pack "MetaClass",
BS.pack "super_" `BS.append` eHaskellName e,
eHaskellName e `BS.snoc` '_' ]
EnumEntity complete values ->
@@ -56,11 +57,13 @@
LocalModule m
-> text "import {-# SOURCE #-}" <+> textBS m
<+> parens (textBS (eHaskellName e) <> comma
- <+> textBS (eHaskellName e) <> text "Class")
+ <+> textBS (eHaskellName e) <> text "Class" <>
comma
+ <+> textBS (eHaskellName e) <>
text "MetaClass")
FrameworkModule f m
-> text "import" <+> textBS m
<+> parens (textBS (eHaskellName e) <> comma
- <+> textBS (eHaskellName e) <> text "Class")
+ <+> textBS (eHaskellName e) <> text "Class" <>
comma
+ <+> textBS (eHaskellName e) <>
text "MetaClass")
pprHsBoot entityPile modName entities
= text "module" <+> textBS modName <+> text "where" $+$
@@ -78,6 +81,9 @@
<+> parens (textBS name <> char '_' <+> char 'a')
$+$
text "type" <+> textBS name <> text "Class" <+>
char 'a' <+> equals
<+> text (maybe "Class" ( (++ "Class") .
BS.unpack . eHaskellName ) mbSuper)
+ <+> parens (textBS name <> char '_' <+> char 'a')
$+$
+ text "type" <+> textBS name <> text "MetaClass" <+>
char 'a' <+> equals
+ <+> text (maybe "MetaClass" ( (++ "MetaClass") .
BS.unpack . eHaskellName ) mbSuper)
<+> parens (textBS name <> char '_' <+> char 'a')
| (name, mbSuper) <- classes0 ]
Modified: trunk/hoc/Setup.hs
==============================================================================
--- trunk/hoc/Setup.hs (original)
+++ trunk/hoc/Setup.hs Sun Dec 21 13:42:00 2008
@@ -1,6 +1,8 @@
import Distribution.Simple
import Distribution.PackageDescription
+import Distribution.Simple.Build
import Distribution.Simple.Setup
+import Distribution.Simple.PreProcess
import Distribution.Simple.Configure
import Distribution.Simple.LocalBuildInfo
import System.Cmd( system )
@@ -13,9 +15,46 @@
main = defaultMainWithHooks $ simpleUserHooks {
confHook = customConfig,
- preBuild = customPreBuild
+ buildHook = customBuild
}
+
+-- You probably don't need to change this, but if you do beware that
+-- it will not be sanitized for the shell.
+cbitsObjectFile = "dist/build/HOC_cbits.o"
+
+needsCBitsWhileBuilding :: Executable -> Bool
+needsCBitsWhileBuilding e
+ | exeName e == "hoc-test" = True
+ | otherwise = False
+
+objc2_flagName = FlagName "objc2"
+
+setObjC2Flag :: ConfigFlags -> IO ConfigFlags
+setObjC2Flag cf
+ -- if the flag is set on the command line, do nothing
+ | lookup (objc2_flagName) (configConfigurationsFlags cf) /= Nothing
+ = return cf
+
+ -- if we're not on darwin, assume false
+ | System.Info.os /= "darwin"
+ = return $ addFlag objc2_flagName False cf
+
+ -- otherwise make an educated guess
+ | otherwise
+ = do
+ value <- objC2Available
+ return $ addFlag objc2_flagName value cf
+ where addFlag flag value cf = cf { configConfigurationsFlags =
+ (flag,value) : configConfigurationsFlags cf }
+
+objC2Available :: IO Bool
+objC2Available
+ | System.Info.os /= "darwin" = return False
+ | otherwise = do
+ result <- system "grep -qR /usr/include/objc -e
objc_allocateClassPair"
+ return (result == ExitSuccess)
+
backquote :: String -> IO String
backquote cmd = do
(inp,out,err,pid) <- runInteractiveCommand cmd
@@ -43,6 +82,8 @@
customConfig :: (Either GenericPackageDescription PackageDescription,
HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo
customConfig pdbi cf = do
+ cf <- setObjC2Flag cf
+
lbi <- configure pdbi cf
if System.Info.os == "darwin"
then return()
@@ -52,48 +93,56 @@
return lbi
-customPreBuild :: Args -> BuildFlags -> IO HookedBuildInfo
-customPreBuild args buildFlags = do
- putStrLn "Compiling HOC_cbits..."
- system "mkdir -p dist/build/"
+customBuild :: PackageDescription -> LocalBuildInfo -> UserHooks ->
BuildFlags -> IO ()
+customBuild pd lbi hooks buildFlags = do
+ let Just libInfo = library pd
+
+ extraFlags <- buildCBits (libBuildInfo libInfo)
+
+ let hooked_pd = pd
+ { library = Just $ libInfo
+ { libBuildInfo = addCompilerFlags extraFlags
+ (libBuildInfo libInfo)
+ }
+ , executables = alterExecutable needsCBitsWhileBuilding
+ (\exe -> exe {buildInfo = addCompilerFlags
extraFlags (buildInfo exe)})
+ (executables pd)
+ }
- (cflags, paths, extralibs) <-
- if System.Info.os == "darwin"
- then do
- return ("-I/usr/include/ffi -DMACOSX", [], ["-framework
Foundation"])
- else do
- (gcclibdir, system_libs, system_headers) <- gnustepPaths
- ffi_cflags <- backquote "pkg-config libffi --cflags"
- return ("-I" ++ system_headers ++ " -DGNUSTEP" ++ " " ++
ffi_cflags,
- ["-L" ++ gcclibdir, "-L" ++ system_libs],
- ["-lgnustep-base"])
+ build hooked_pd lbi buildFlags knownSuffixHandlers
+-- |Build HOC_cbits.o using the flags specified in the configuration
+-- stage, and return a list of flags to add to support usage of
+-- template-haskell while compiling (for both the library and the
+-- hoc-test executable)
+buildCBits :: BuildInfo -> IO [(CompilerFlavor, [String])]
+buildCBits buildInfo = do
+ putStrLn "Compiling HOC_cbits..."
+ system ("mkdir -p " ++ takeDirectory cbitsObjectFile)
+
+ let cflags = cppOptions buildInfo ++ ccOptions buildInfo
+ ++ ["-I" ++ dir | dir <- includeDirs buildInfo]
+ extraGHCflags = [cbitsObjectFile]
+ ++ ["-l" ++ lib | lib <- extraLibs buildInfo]
+ ++ ["-framework " ++ fw | fw <- frameworks buildInfo]
+
exitCode <- system $ "gcc -r -nostdlib -I`ghc --print-libdir`/include "
- ++ cflags ++ " HOC_cbits/*.m -o dist/build/HOC_cbits.o"
-
+ ++ unwords cflags
+ ++ " HOC_cbits/*.m -o " ++ cbitsObjectFile
+
case exitCode of
ExitSuccess -> return ()
_ -> fail "Failed in C compilation."
- -- system "cp dist/build/HOC_cbits.o dist/build/HOC_cbits.dyn_o"
- system "cp dist/build/HOC_cbits.o dist/build/hoc-test/hoc-test-tmp/"
-
- let buildInfo = emptyBuildInfo {
- options = [ (GHC, ["dist/build/HOC_cbits.o" ]
- ++ paths ++
- ["-lobjc",
- "-lffi"]
- ++ extralibs) ],
- cSources = ["HOC_cbits.o"]
- }
- buildInfo2 = emptyBuildInfo {
- options = [ (GHC,
["dist/build/hoc-test/hoc-test-tmp/HOC_cbits.o" ]
- ++ paths ++
- ["-lobjc",
- "-lffi"]
- ++ extralibs) ]{-,
- cSources = ["HOC_cbits.o"]-}
- }
-
- return (Just buildInfo, [("hoc-test", buildInfo2)])
+ return [(GHC, extraGHCflags)]
+
+-- TODO: check whether it's OK for the options field to have multiple
+-- entries for the same "compiler flavor"
+addCompilerFlags :: [(CompilerFlavor,[String])] -> BuildInfo -> BuildInfo
+addCompilerFlags flags buildInfo = buildInfo {
+ options = flags ++ options buildInfo
+ }
+alterExecutable :: (Executable -> Bool) -> (Executable -> Executable)
+ -> [Executable] -> [Executable]
+alterExecutable p f exes = [if p exe then f exe else exe | exe <- exes]
\ No newline at end of file
Modified: trunk/hoc/Tests/TestFoundation.hs
==============================================================================
--- trunk/hoc/Tests/TestFoundation.hs (original)
+++ trunk/hoc/Tests/TestFoundation.hs Sun Dec 21 13:42:00 2008
@@ -94,16 +94,19 @@
$(declareClass "HaskellObjectCountingInvocations" "NSObject")
$(exportClass "HaskellObjectCountingInvocations" "hoci_1_" [
- InstanceMethod 'countInvocationsUpto
+ InstanceMethod 'countInvocationsUpto,
+ ClassMethod 'countInvocationsUpto
])
instance Has_countInvocationsUpto (HaskellObjectCountingInvocations a)
+instance Has_countInvocationsUpto (HaskellObjectCountingInvocationsClass a)
hoci_1_countInvocationsUpto start limit self = return (start + 1)
$(declareClass "HaskellObjectUsingSuper" "HaskellObjectCountingInvocations")
$(exportClass "HaskellObjectUsingSuper" "hoci_2_" [
- InstanceMethod 'countInvocationsUpto
+ InstanceMethod 'countInvocationsUpto,
+ ClassMethod 'countInvocationsUpto
])
hoci_2_countInvocationsUpto start limit self
@@ -268,7 +271,7 @@
str <- hobj # description
fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
),
- "chaining" ~: test [
+ "instanceChaining" ~: test [
"base" ~: (assertNoLeaks $ do
hobj <- _HaskellObjectCountingInvocations # alloc >>=
init
count <- hobj # countInvocationsUpto 0 100
@@ -284,6 +287,22 @@
count <- hobj # countInvocationsUpto 0 100
count @?= 2
)
+
+ ],
+ "classChaining" ~: test [
+ "base" ~: (assertNoLeaks $ do
+ count <- _HaskellObjectCountingInvocations #
countInvocationsUpto 0 100
+ count @?= 1
+ ),
+ "subclass" ~: (assertNoLeaks $ do
+ count <- _HaskellObjectUsingSuper #
countInvocationsUpto 0 100
+ count @?= 2
+ ),
+ "subsubclass" ~: (assertNoLeaks $ do
+ count <- _HaskellSubclassOfObjectUsingSuper #
countInvocationsUpto 0 100
+ count @?= 2
+ )
+
]
],
"structs" ~: test [
|
|
From: <cod...@go...> - 2008-12-10 22:32:17
|
Author: jam...@us...
Date: Wed Dec 10 14:10:22 2008
New Revision: 376
Modified:
/ (props changed)
branches/objc2/hoc/HOC.cabal
branches/objc2/hoc/Setup.hs
Log:
r380@Macintosh: james.cook | 2008-12-10 17:09:59 -0500
(objc2 branch) Added simple autodetection for ObjC2 build flag.
Modified: branches/objc2/hoc/HOC.cabal
==============================================================================
--- branches/objc2/hoc/HOC.cabal (original)
+++ branches/objc2/hoc/HOC.cabal Wed Dec 10 14:10:22 2008
@@ -16,7 +16,6 @@
Flag ObjC2
description: build for Objective-C 2.0
- default: False
Library
build-depends: base, template-haskell, unix
Modified: branches/objc2/hoc/Setup.hs
==============================================================================
--- branches/objc2/hoc/Setup.hs (original)
+++ branches/objc2/hoc/Setup.hs Wed Dec 10 14:10:22 2008
@@ -27,6 +27,34 @@
| exeName e == "hoc-test" = True
| otherwise = False
+objc2_flagName = FlagName "objc2"
+
+setObjC2Flag :: ConfigFlags -> IO ConfigFlags
+setObjC2Flag cf
+ -- if the flag is set on the command line, do nothing
+ | lookup (objc2_flagName) (configConfigurationsFlags cf) /= Nothing
+ = return cf
+
+ -- if we're not on darwin, assume false
+ | System.Info.os /= "darwin"
+ = return $ addFlag objc2_flagName False cf
+
+ -- otherwise make an educated guess
+ | otherwise
+ = do
+ value <- objC2Available
+ return $ addFlag objc2_flagName value cf
+
+ where addFlag flag value cf = cf { configConfigurationsFlags =
+ (flag,value) : configConfigurationsFlags cf }
+
+objC2Available :: IO Bool
+objC2Available
+ | System.Info.os /= "darwin" = return False
+ | otherwise = do
+ result <- system "grep -qR /usr/include/objc -e
objc_allocateClassPair"
+ return (result == ExitSuccess)
+
backquote :: String -> IO String
backquote cmd = do
(inp,out,err,pid) <- runInteractiveCommand cmd
@@ -54,6 +82,8 @@
customConfig :: (Either GenericPackageDescription PackageDescription,
HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo
customConfig pdbi cf = do
+ cf <- setObjC2Flag cf
+
lbi <- configure pdbi cf
if System.Info.os == "darwin"
then return()
|
|
From: <cod...@go...> - 2008-12-10 16:32:18
|
Author: jam...@us...
Date: Wed Dec 10 08:29:58 2008
New Revision: 375
Modified:
branches/objc2/hoc/InterfaceGenerator2/Output.hs
Log:
(objc2 branch) Updated InterfaceGenerator2 to properly import and export
metaclasses in support of r374.
Modified: branches/objc2/hoc/InterfaceGenerator2/Output.hs
==============================================================================
--- branches/objc2/hoc/InterfaceGenerator2/Output.hs (original)
+++ branches/objc2/hoc/InterfaceGenerator2/Output.hs Wed Dec 10 08:29:58
2008
@@ -25,6 +25,7 @@
ClassEntity _ ->
[eHaskellName e, '_' `BS.cons` eHaskellName e,
eHaskellName e `BS.append` BS.pack "Class",
+ eHaskellName e `BS.append` BS.pack "MetaClass",
BS.pack "super_" `BS.append` eHaskellName e,
eHaskellName e `BS.snoc` '_' ]
EnumEntity complete values ->
@@ -56,11 +57,13 @@
LocalModule m
-> text "import {-# SOURCE #-}" <+> textBS m
<+> parens (textBS (eHaskellName e) <> comma
- <+> textBS (eHaskellName e) <> text "Class")
+ <+> textBS (eHaskellName e) <> text "Class" <>
comma
+ <+> textBS (eHaskellName e) <>
text "MetaClass")
FrameworkModule f m
-> text "import" <+> textBS m
<+> parens (textBS (eHaskellName e) <> comma
- <+> textBS (eHaskellName e) <> text "Class")
+ <+> textBS (eHaskellName e) <> text "Class" <>
comma
+ <+> textBS (eHaskellName e) <>
text "MetaClass")
pprHsBoot entityPile modName entities
= text "module" <+> textBS modName <+> text "where" $+$
@@ -78,6 +81,9 @@
<+> parens (textBS name <> char '_' <+> char 'a')
$+$
text "type" <+> textBS name <> text "Class" <+>
char 'a' <+> equals
<+> text (maybe "Class" ( (++ "Class") .
BS.unpack . eHaskellName ) mbSuper)
+ <+> parens (textBS name <> char '_' <+> char 'a')
$+$
+ text "type" <+> textBS name <> text "MetaClass" <+>
char 'a' <+> equals
+ <+> text (maybe "MetaClass" ( (++ "MetaClass") .
BS.unpack . eHaskellName ) mbSuper)
<+> parens (textBS name <> char '_' <+> char 'a')
| (name, mbSuper) <- classes0 ]
|
|
From: <cod...@go...> - 2008-12-10 16:24:15
|
Author: jam...@us...
Date: Wed Dec 10 07:59:54 2008
New Revision: 374
Modified:
branches/objc2/hoc/HOC/HOC.hs
branches/objc2/hoc/HOC/HOC/Class.hs
branches/objc2/hoc/HOC/HOC/DeclareClass.hs
branches/objc2/hoc/Tests/TestFoundation.hs
Log:
Experimental patch (committed to objc2 branch only for now, though it's not
at all specific to objective c 2.0 - I just wasn't sure if it was too
disruptive to push to the trunk) extending previous work on super calls to
cover class methods.
This involved adding a fair bit to the output of declareClass - if anyone
sees a better way to do this, I'd love to hear about it. One thing I
thought about was using an instance of the form:
instance ClassAndObject meta $(metaClsType) => ClassObject meta
where classObject = unsafeGetMetaclassForClass classObject
I believe this would have "worked" with slightly less clutter in the
namespace, but it would require adding FlexibleContexts to the LANGUAGE
pragma
of every source file that calls declareClass, which seemed even more
disruptive.
Modified: branches/objc2/hoc/HOC/HOC.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC.hs (original)
+++ branches/objc2/hoc/HOC/HOC.hs Wed Dec 10 07:59:54 2008
@@ -4,6 +4,7 @@
nil,
Object(..),
Class,
+ MetaClass,
ClassAndObject,
ClassObject,
classObject,
Modified: branches/objc2/hoc/HOC/HOC/Class.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/Class.hs (original)
+++ branches/objc2/hoc/HOC/HOC/Class.hs Wed Dec 10 07:59:54 2008
@@ -11,15 +11,13 @@
import Foreign
import Foreign.C.String
-
data Class_ a
type Class a = ID (Class_ a)
-
+type MetaClass a = Class (Class_ a)
unsafeGetClassObject :: String -> Class a
-
foreign import ccall unsafe "Class.h getClassByName"
c_getClassByName :: CString -> IO (Ptr ObjCObject)
@@ -30,6 +28,16 @@
getClassByName name >>= importImmortal
+unsafeGetMetaclassForClass :: Class a -> MetaClass a
+
+foreign import ccall unsafe "Class.h getClassForObject"
+ c_getClassForObject :: Ptr ObjCObject -> IO (Ptr ObjCObject)
+
+getClassForObject obj = withExportedArgument obj c_getClassForObject
+
+{-# NOINLINE unsafeGetMetaclassForClass #-}
+unsafeGetMetaclassForClass obj = unsafePerformIO $
+ getClassForObject obj >>= importImmortal
class (Object a, Object b) => ClassAndObject a b | a -> b, b -> a
Modified: branches/objc2/hoc/HOC/HOC/DeclareClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/DeclareClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/DeclareClass.hs Wed Dec 10 07:59:54 2008
@@ -31,6 +31,12 @@
`appT` (conT (mkName phantomName)
`appT` varT (mkName "a"))),
+ -- type $(metaMetaClassName) a = $(superMetaMetaClassName)
($(phantomName) a)
+ tySynD (mkName metaMetaClassName) [mkName "a"]
+ (conT (mkName superMetaMetaClassName)
+ `appT` (conT (mkName phantomName)
+ `appT` varT (mkName "a"))),
+
-- $(classObjectName) :: $(metaClassName) ()
sigD (mkName classObjectName) (conT (mkName metaClassName)
`appT` [t| () |]),
@@ -39,6 +45,11 @@
valD (return $ VarP (mkName classObjectName))
(normalB [| unsafeGetClassObject $(stringE name) |]) [],
+ -- $(metaClassObjectName) = unsafeGetMetaclassForClass
$(classObjectName)
+ valD (return $ VarP (mkName metaClassObjectName))
+ (normalB [| unsafeGetMetaclassForClass $(varE (mkName
classObjectName)) |]) [],
+
+ -- $(superName) :: String
sigD (mkName superName) [t| String |],
-- $(superName) = "super"
@@ -47,20 +58,35 @@
-- instance SuperClass (name ()) (super ())
instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`
superType) [],
+ -- instance SuperClass (clsName ()) (superClsName ())
+ instanceD (cxt []) (conT ''SuperClass `appT` metaClsType `appT`
superMetaType) [],
+
-- instance ClassObject (metaClsName ())
-- where classObject = classObject
instanceD (cxt []) (conT ''ClassObject `appT` metaClsType)
- [funD 'classObject [clause [] (normalB $ varE (mkName
classObjectName)) []]]
+ [funD 'classObject [clause [] (normalB $ varE (mkName
classObjectName)) []]],
+
+ -- instance ClassObject metaMetaCls
+ -- where classObject = unsafeGetMetaclassForClass classObject
+ -- {- metaclass object, to support super calls in class methods -}
+ instanceD (cxt []) (conT ''ClassObject `appT` metaMetaClsType)
+ [funD 'classObject [clause [] (normalB $ varE (mkName
metaClassObjectName)) []]]
]
where
phantomName = name ++ "_"
metaClassName = name ++ "Class"
+ metaMetaClassName = name ++ "MetaClass"
metaPhantomName = metaClassName ++ "_"
superMetaClassName | super == "ID" = "Class"
| otherwise = super ++ "Class"
+ superMetaMetaClassName | super == "ID" = "MetaClass"
+ | otherwise = super ++ "MetaClass"
classObjectName = "_" ++ name
+ metaClassObjectName = "_" ++ metaClassName
superName = "super_" ++ name
+ metaMetaClsType = conT (mkName metaMetaClassName) `appT` [t| () |]
metaClsType = conT (mkName metaClassName) `appT` [t| () |]
clsType = conT (mkName name) `appT` [t| () |]
superType = conT (mkName super) `appT` [t| () |]
+ superMetaType = conT (mkName superMetaClassName) `appT` [t| () |]
Modified: branches/objc2/hoc/Tests/TestFoundation.hs
==============================================================================
--- branches/objc2/hoc/Tests/TestFoundation.hs (original)
+++ branches/objc2/hoc/Tests/TestFoundation.hs Wed Dec 10 07:59:54 2008
@@ -94,16 +94,19 @@
$(declareClass "HaskellObjectCountingInvocations" "NSObject")
$(exportClass "HaskellObjectCountingInvocations" "hoci_1_" [
- InstanceMethod 'countInvocationsUpto
+ InstanceMethod 'countInvocationsUpto,
+ ClassMethod 'countInvocationsUpto
])
instance Has_countInvocationsUpto (HaskellObjectCountingInvocations a)
+instance Has_countInvocationsUpto (HaskellObjectCountingInvocationsClass a)
hoci_1_countInvocationsUpto start limit self = return (start + 1)
$(declareClass "HaskellObjectUsingSuper" "HaskellObjectCountingInvocations")
$(exportClass "HaskellObjectUsingSuper" "hoci_2_" [
- InstanceMethod 'countInvocationsUpto
+ InstanceMethod 'countInvocationsUpto,
+ ClassMethod 'countInvocationsUpto
])
hoci_2_countInvocationsUpto start limit self
@@ -268,7 +271,7 @@
str <- hobj # description
fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
),
- "chaining" ~: test [
+ "instanceChaining" ~: test [
"base" ~: (assertNoLeaks $ do
hobj <- _HaskellObjectCountingInvocations # alloc >>=
init
count <- hobj # countInvocationsUpto 0 100
@@ -284,6 +287,22 @@
count <- hobj # countInvocationsUpto 0 100
count @?= 2
)
+
+ ],
+ "classChaining" ~: test [
+ "base" ~: (assertNoLeaks $ do
+ count <- _HaskellObjectCountingInvocations #
countInvocationsUpto 0 100
+ count @?= 1
+ ),
+ "subclass" ~: (assertNoLeaks $ do
+ count <- _HaskellObjectUsingSuper #
countInvocationsUpto 0 100
+ count @?= 2
+ ),
+ "subsubclass" ~: (assertNoLeaks $ do
+ count <- _HaskellSubclassOfObjectUsingSuper #
countInvocationsUpto 0 100
+ count @?= 2
+ )
+
]
],
"structs" ~: test [
|
|
From: <cod...@go...> - 2008-12-10 15:00:30
|
Author: jam...@us...
Date: Wed Dec 10 06:53:54 2008
New Revision: 373
Modified:
branches/objc2/hoc/HOC/HOC.hs
branches/objc2/hoc/HOC/HOC/Class.hs
branches/objc2/hoc/HOC/HOC/DeclareClass.hs
branches/objc2/hoc/HOC/HOC/NewlyAllocated.hs
branches/objc2/hoc/HOC/HOC/Super.hs
Log:
Same as r372, applied to objc2 branch.
Modified: branches/objc2/hoc/HOC/HOC.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC.hs (original)
+++ branches/objc2/hoc/HOC/HOC.hs Wed Dec 10 06:53:54 2008
@@ -5,9 +5,8 @@
Object(..),
Class,
ClassAndObject,
- StaticClassAndObject,
- staticClassForObject,
- staticSuperclassForObject,
+ ClassObject,
+ classObject,
( # ), ( #. ),
withExportedArray,
castObject,
Modified: branches/objc2/hoc/HOC/HOC/Class.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/Class.hs (original)
+++ branches/objc2/hoc/HOC/HOC/Class.hs Wed Dec 10 06:53:54 2008
@@ -36,13 +36,6 @@
instance ClassAndObject (Class a) (ID a)
-class ClassAndObject a b => StaticClassAndObject a b
- where
- -- _staticClassForObject must not touch its parameter:
- -- its value should only depend on the type of the parameter.
- _staticClassForObject :: b -> a
-
--- make an export-safe version; don't want people making new
--- implementations, but they should be allowed to use the info.
-staticClassForObject :: StaticClassAndObject a b => b -> a
-staticClassForObject = _staticClassForObject
\ No newline at end of file
+class Object cls => ClassObject cls
+ where
+ classObject :: cls
Modified: branches/objc2/hoc/HOC/HOC/DeclareClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/DeclareClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/DeclareClass.hs Wed Dec 10 06:53:54 2008
@@ -47,10 +47,10 @@
-- instance SuperClass (name ()) (super ())
instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`
superType) [],
- -- instance StaticClassAndObject (name ())
- -- where staticClassForObject _ = classObject
- instanceD (cxt []) (conT ''StaticClassAndObject `appT` metaClsType
`appT` clsType)
- [funD '_staticClassForObject [clause [wildP] (normalB $ varE
(mkName classObjectName)) []]]
+ -- instance ClassObject (metaClsName ())
+ -- where classObject = classObject
+ instanceD (cxt []) (conT ''ClassObject `appT` metaClsType)
+ [funD 'classObject [clause [] (normalB $ varE (mkName
classObjectName)) []]]
]
where
phantomName = name ++ "_"
Modified: branches/objc2/hoc/HOC/HOC/NewlyAllocated.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/NewlyAllocated.hs (original)
+++ branches/objc2/hoc/HOC/HOC/NewlyAllocated.hs Wed Dec 10 06:53:54 2008
@@ -1,4 +1,5 @@
-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,
UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,
UndecidableInstances,
+ ScopedTypeVariables #-}
module HOC.NewlyAllocated where
{-
@@ -55,9 +56,6 @@
sendMessageWithoutRetval (NewlyAllocated _) =
objSendMessageWithoutRetval
sendMessageWithoutRetval (NewSuper _ _) = superSendMessageWithoutRetval
-instance (SuperClass sub (ID super), StaticClassAndObject (Class super)
(ID super))
+instance (SuperClass sub (ID super), ClassObject (Class super))
=> Super (NewlyAllocated sub) (NewlyAllocated (ID super)) where
- super na@(NewlyAllocated x) = NewSuper x (castObject superClass)
- where superClass = staticClassForObject (asSuper na)
- asSuper :: SuperClass sub super => NewlyAllocated sub ->
super
- asSuper _ = error "staticClassForObject must not touch its
parameter"
+ super (NewlyAllocated x) = NewSuper x (castObject (classObject ::
Class super))
Modified: branches/objc2/hoc/HOC/HOC/Super.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/Super.hs (original)
+++ branches/objc2/hoc/HOC/HOC/Super.hs Wed Dec 10 06:53:54 2008
@@ -2,8 +2,7 @@
UndecidableInstances, FlexibleInstances,
FlexibleContexts #-}
module HOC.Super(
- SuperClass, SuperTarget, Super(super), withExportedSuper,
- staticSuperclassForObject, castSuper
+ SuperClass, SuperTarget, Super(super), withExportedSuper, castSuper
) where
import HOC.Base
@@ -58,14 +57,14 @@
staticSuperclassForObject ::
( SuperClass (ID sub) (ID super)
- , StaticClassAndObject (Class super) (ID super)
+ , ClassObject (Class super)
) => ID sub -> Class super
-staticSuperclassForObject = staticClassForObject . castSuper
+staticSuperclassForObject obj = classObject
instance (Object (ID sub), Object (ID super), SuperClass (ID sub) (ID
super),
- StaticClassAndObject (Class super) (ID super))
+ ClassObject (Class super))
=> Super (ID sub) (SuperTarget (ID super)) where
- super obj = SuperTarget (fromID $ toID obj) (castObject
(staticSuperclassForObject obj))
+ super obj = SuperTarget (castSuper obj) (castObject
(staticSuperclassForObject obj))
instance MessageTarget a => MessageTarget (SuperTarget a) where
isNil (SuperTarget x cls) = isNil x || isNil cls
|
|
From: <cod...@go...> - 2008-12-10 14:56:22
|
Author: jam...@us...
Date: Wed Dec 10 06:52:25 2008
New Revision: 372
Modified:
trunk/hoc/HOC/HOC.hs
trunk/hoc/HOC/HOC/Class.hs
trunk/hoc/HOC/HOC/DeclareClass.hs
trunk/hoc/HOC/HOC/NewlyAllocated.hs
trunk/hoc/HOC/HOC/Super.hs
Log:
Simplified previous patch for Issue 9 by replacing
newly-introduced "StaticClassAndObject" typeclass with a
simpler "ClassObject" typeclass.
This patch touches the template-haskell code, so bindings will have to be
rebuilt. Sorry for any inconvenience this may cause.
Modified: trunk/hoc/HOC/HOC.hs
==============================================================================
--- trunk/hoc/HOC/HOC.hs (original)
+++ trunk/hoc/HOC/HOC.hs Wed Dec 10 06:52:25 2008
@@ -5,9 +5,8 @@
Object(..),
Class,
ClassAndObject,
- StaticClassAndObject,
- staticClassForObject,
- staticSuperclassForObject,
+ ClassObject,
+ classObject,
( # ), ( #. ),
withExportedArray,
castObject,
Modified: trunk/hoc/HOC/HOC/Class.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Class.hs (original)
+++ trunk/hoc/HOC/HOC/Class.hs Wed Dec 10 06:52:25 2008
@@ -36,13 +36,6 @@
instance ClassAndObject (Class a) (ID a)
-class ClassAndObject a b => StaticClassAndObject a b
- where
- -- _staticClassForObject must not touch its parameter:
- -- its value should only depend on the type of the parameter.
- _staticClassForObject :: b -> a
-
--- make an export-safe version; don't want people making new
--- implementations, but they should be allowed to use the info.
-staticClassForObject :: StaticClassAndObject a b => b -> a
-staticClassForObject = _staticClassForObject
\ No newline at end of file
+class Object cls => ClassObject cls
+ where
+ classObject :: cls
Modified: trunk/hoc/HOC/HOC/DeclareClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/DeclareClass.hs (original)
+++ trunk/hoc/HOC/HOC/DeclareClass.hs Wed Dec 10 06:52:25 2008
@@ -47,10 +47,10 @@
-- instance SuperClass (name ()) (super ())
instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`
superType) [],
- -- instance StaticClassAndObject (name ())
- -- where staticClassForObject _ = classObject
- instanceD (cxt []) (conT ''StaticClassAndObject `appT` metaClsType
`appT` clsType)
- [funD '_staticClassForObject [clause [wildP] (normalB $ varE
(mkName classObjectName)) []]]
+ -- instance ClassObject (metaClsName ())
+ -- where classObject = classObject
+ instanceD (cxt []) (conT ''ClassObject `appT` metaClsType)
+ [funD 'classObject [clause [] (normalB $ varE (mkName
classObjectName)) []]]
]
where
phantomName = name ++ "_"
Modified: trunk/hoc/HOC/HOC/NewlyAllocated.hs
==============================================================================
--- trunk/hoc/HOC/HOC/NewlyAllocated.hs (original)
+++ trunk/hoc/HOC/HOC/NewlyAllocated.hs Wed Dec 10 06:52:25 2008
@@ -1,4 +1,5 @@
-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,
UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,
UndecidableInstances,
+ ScopedTypeVariables #-}
module HOC.NewlyAllocated where
{-
@@ -55,9 +56,6 @@
sendMessageWithoutRetval (NewlyAllocated _) =
objSendMessageWithoutRetval
sendMessageWithoutRetval (NewSuper _ _) = superSendMessageWithoutRetval
-instance (SuperClass sub (ID super), StaticClassAndObject (Class super)
(ID super))
+instance (SuperClass sub (ID super), ClassObject (Class super))
=> Super (NewlyAllocated sub) (NewlyAllocated (ID super)) where
- super na@(NewlyAllocated x) = NewSuper x (castObject superClass)
- where superClass = staticClassForObject (asSuper na)
- asSuper :: SuperClass sub super => NewlyAllocated sub ->
super
- asSuper _ = error "staticClassForObject must not touch its
parameter"
+ super (NewlyAllocated x) = NewSuper x (castObject (classObject ::
Class super))
Modified: trunk/hoc/HOC/HOC/Super.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Super.hs (original)
+++ trunk/hoc/HOC/HOC/Super.hs Wed Dec 10 06:52:25 2008
@@ -2,8 +2,7 @@
UndecidableInstances, FlexibleInstances,
FlexibleContexts #-}
module HOC.Super(
- SuperClass, SuperTarget, Super(super), withExportedSuper,
- staticSuperclassForObject, castSuper
+ SuperClass, SuperTarget, Super(super), withExportedSuper, castSuper
) where
import HOC.Base
@@ -58,14 +57,14 @@
staticSuperclassForObject ::
( SuperClass (ID sub) (ID super)
- , StaticClassAndObject (Class super) (ID super)
+ , ClassObject (Class super)
) => ID sub -> Class super
-staticSuperclassForObject = staticClassForObject . castSuper
+staticSuperclassForObject obj = classObject
instance (Object (ID sub), Object (ID super), SuperClass (ID sub) (ID
super),
- StaticClassAndObject (Class super) (ID super))
+ ClassObject (Class super))
=> Super (ID sub) (SuperTarget (ID super)) where
- super obj = SuperTarget (fromID $ toID obj) (castObject
(staticSuperclassForObject obj))
+ super obj = SuperTarget (castSuper obj) (castObject
(staticSuperclassForObject obj))
instance MessageTarget a => MessageTarget (SuperTarget a) where
isNil (SuperTarget x cls) = isNil x || isNil cls
|
|
From: <cod...@go...> - 2008-12-09 22:45:37
|
Author: jam...@us...
Date: Tue Dec 9 12:37:44 2008
New Revision: 369
Modified:
branches/objc2/hoc/HOC/HOC.hs
branches/objc2/hoc/HOC/HOC/Class.hs
branches/objc2/hoc/HOC/HOC/DeclareClass.hs
branches/objc2/hoc/HOC/HOC/NewlyAllocated.hs
branches/objc2/hoc/HOC/HOC/Super.hs
branches/objc2/hoc/Tests/TestFoundation.hs
Log:
Pushing same changes in r368 (super call chaining fix) to objc2 branch.
Modified: branches/objc2/hoc/HOC/HOC.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC.hs (original)
+++ branches/objc2/hoc/HOC/HOC.hs Tue Dec 9 12:37:44 2008
@@ -5,6 +5,9 @@
Object(..),
Class,
ClassAndObject,
+ StaticClassAndObject,
+ staticClassForObject,
+ staticSuperclassForObject,
( # ), ( #. ),
withExportedArray,
castObject,
@@ -36,6 +39,7 @@
SuperClass,
SuperTarget,
super,
+ castSuper,
CEnum(..),
declareCEnum,
Modified: branches/objc2/hoc/HOC/HOC/Class.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/Class.hs (original)
+++ branches/objc2/hoc/HOC/HOC/Class.hs Tue Dec 9 12:37:44 2008
@@ -35,3 +35,14 @@
class (Object a, Object b) => ClassAndObject a b | a -> b, b -> a
instance ClassAndObject (Class a) (ID a)
+
+class ClassAndObject a b => StaticClassAndObject a b
+ where
+ -- _staticClassForObject must not touch its parameter:
+ -- its value should only depend on the type of the parameter.
+ _staticClassForObject :: b -> a
+
+-- make an export-safe version; don't want people making new
+-- implementations, but they should be allowed to use the info.
+staticClassForObject :: StaticClassAndObject a b => b -> a
+staticClassForObject = _staticClassForObject
\ No newline at end of file
Modified: branches/objc2/hoc/HOC/HOC/DeclareClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/DeclareClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/DeclareClass.hs Tue Dec 9 12:37:44 2008
@@ -45,7 +45,12 @@
valD (return $ VarP (mkName superName)) (normalB $ stringE super)
[],
-- instance SuperClass (name ()) (super ())
- instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`
superType) []
+ instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`
superType) [],
+
+ -- instance StaticClassAndObject (name ())
+ -- where staticClassForObject _ = classObject
+ instanceD (cxt []) (conT ''StaticClassAndObject `appT` metaClsType
`appT` clsType)
+ [funD '_staticClassForObject [clause [wildP] (normalB $ varE
(mkName classObjectName)) []]]
]
where
phantomName = name ++ "_"
@@ -56,5 +61,6 @@
classObjectName = "_" ++ name
superName = "super_" ++ name
+ metaClsType = conT (mkName metaClassName) `appT` [t| () |]
clsType = conT (mkName name) `appT` [t| () |]
superType = conT (mkName super) `appT` [t| () |]
Modified: branches/objc2/hoc/HOC/HOC/NewlyAllocated.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/NewlyAllocated.hs (original)
+++ branches/objc2/hoc/HOC/HOC/NewlyAllocated.hs Tue Dec 9 12:37:44 2008
@@ -14,6 +14,8 @@
import HOC.Base ( ObjCObject )
import HOC.Arguments ( ObjCArgument(..) )
+import HOC.Class
+import HOC.ID
import HOC.MessageTarget( Object(..), MessageTarget(..) )
import HOC.MsgSend
import HOC.Super
@@ -24,15 +26,16 @@
data NewlyAllocated a
= NewlyAllocated (Ptr ObjCObject)
- | NewSuper (Ptr ObjCObject)
+ | NewSuper (Ptr ObjCObject) (Class ())
instance ObjCArgument (NewlyAllocated a) (Ptr ObjCObject) where
withExportedArgument (NewlyAllocated p) action = action p
- withExportedArgument (NewSuper p) action =
- withExportedSuper p action
+ withExportedArgument (NewSuper p cls) action =
+ withExportedArgument cls $ \cls ->
+ withExportedSuper p cls action
exportArgument (NewlyAllocated p) = return p
- exportArgument (NewSuper p) = fail "HOC.NewlyAllocated.NewSuper:
exportArgument"
+ exportArgument (NewSuper p cls) = fail "HOC.NewlyAllocated.NewSuper:
exportArgument"
importArgument p = return (NewlyAllocated p)
@@ -45,13 +48,16 @@
instance MessageTarget (NewlyAllocated a) where
isNil (NewlyAllocated p) = p == nullPtr
- isNil (NewSuper p) = p == nullPtr
+ isNil (NewSuper p cls) = (p == nullPtr) || isNil cls
sendMessageWithRetval (NewlyAllocated _) = objSendMessageWithRetval
- sendMessageWithRetval (NewSuper _) = superSendMessageWithRetval
+ sendMessageWithRetval (NewSuper _ _) = superSendMessageWithRetval
sendMessageWithoutRetval (NewlyAllocated _) =
objSendMessageWithoutRetval
- sendMessageWithoutRetval (NewSuper _) = superSendMessageWithoutRetval
+ sendMessageWithoutRetval (NewSuper _ _) = superSendMessageWithoutRetval
-instance SuperClass sub super
- => Super (NewlyAllocated sub) (NewlyAllocated super) where
- super (NewlyAllocated x) = NewSuper x
+instance (SuperClass sub (ID super), StaticClassAndObject (Class super)
(ID super))
+ => Super (NewlyAllocated sub) (NewlyAllocated (ID super)) where
+ super na@(NewlyAllocated x) = NewSuper x (castObject superClass)
+ where superClass = staticClassForObject (asSuper na)
+ asSuper :: SuperClass sub super => NewlyAllocated sub ->
super
+ asSuper _ = error "staticClassForObject must not touch its
parameter"
Modified: branches/objc2/hoc/HOC/HOC/Super.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/Super.hs (original)
+++ branches/objc2/hoc/HOC/HOC/Super.hs Tue Dec 9 12:37:44 2008
@@ -1,12 +1,14 @@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
UndecidableInstances, FlexibleInstances,
- ForeignFunctionInterface #-}
+ FlexibleContexts #-}
module HOC.Super(
- SuperClass, SuperTarget, Super(super), withExportedSuper
+ SuperClass, SuperTarget, Super(super), withExportedSuper,
+ staticSuperclassForObject, castSuper
) where
import HOC.Base
import HOC.Arguments
+import HOC.Class
import HOC.ID
import HOC.MsgSend
import HOC.MessageTarget
@@ -24,7 +26,7 @@
-- super, which is sufficient to define a class hierarchy.
class SuperClass sub super | sub -> super
-data SuperTarget a = SuperTarget a
+data SuperTarget a = SuperTarget a (Class ())
class Super sub super | sub -> super where
super :: sub -> super
@@ -34,32 +36,39 @@
pokeSuper objcSuper obj cls
= pokeByteOff objcSuper 0 obj >> pokeByteOff objcSuper (sizeOf obj) cls
-withExportedSuper p action =
- getSuperClassForObject p >>= \cls ->
+withExportedSuper p cls action =
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 (SuperTarget obj cls) action =
+ withExportedArgument cls $ \cls ->
withExportedArgument obj $ \p ->
- withExportedSuper p action
+ withExportedSuper p cls action
exportArgument _ = fail "HOC.Super: exportArgument"
importArgument _ = fail "HOC.Super: importArgument"
objCTypeString _ = "@" -- well, close enough.
-instance (Object (ID sub), Object super, SuperClass (ID sub) super)
- => Super (ID sub) (SuperTarget super) where
- super obj = SuperTarget (fromID $ toID obj)
+castSuper :: SuperClass (ID sub) (ID super) => ID sub -> ID super
+castSuper = castObject
-foreign import ccall "Class.h getSuperClassForObject"
- getSuperClassForObject :: Ptr ObjCObject -> IO (Ptr ())
+staticSuperclassForObject ::
+ ( SuperClass (ID sub) (ID super)
+ , StaticClassAndObject (Class super) (ID super)
+ ) => ID sub -> Class super
+staticSuperclassForObject = staticClassForObject . castSuper
+
+instance (Object (ID sub), Object (ID super), SuperClass (ID sub) (ID
super),
+ StaticClassAndObject (Class super) (ID super))
+ => Super (ID sub) (SuperTarget (ID super)) where
+ super obj = SuperTarget (fromID $ toID obj) (castObject
(staticSuperclassForObject obj))
instance MessageTarget a => MessageTarget (SuperTarget a) where
- isNil (SuperTarget x) = isNil x
+ isNil (SuperTarget x cls) = isNil x || isNil cls
sendMessageWithRetval _ = superSendMessageWithRetval
sendMessageWithoutRetval _ = superSendMessageWithoutRetval
Modified: branches/objc2/hoc/Tests/TestFoundation.hs
==============================================================================
--- branches/objc2/hoc/Tests/TestFoundation.hs (original)
+++ branches/objc2/hoc/Tests/TestFoundation.hs Tue Dec 9 12:37:44 2008
@@ -90,6 +90,30 @@
nil
>>= raise
+$(declareSelector "countInvocations:upto:" [t| Int -> Int -> IO Int |])
+
+$(declareClass "HaskellObjectCountingInvocations" "NSObject")
+$(exportClass "HaskellObjectCountingInvocations" "hoci_1_" [
+ InstanceMethod 'countInvocationsUpto
+ ])
+
+instance Has_countInvocationsUpto (HaskellObjectCountingInvocations a)
+
+hoci_1_countInvocationsUpto start limit self = return (start + 1)
+
+$(declareClass "HaskellObjectUsingSuper" "HaskellObjectCountingInvocations")
+$(exportClass "HaskellObjectUsingSuper" "hoci_2_" [
+ InstanceMethod 'countInvocationsUpto
+ ])
+
+hoci_2_countInvocationsUpto start limit self
+ | start >= limit = return start
+ | otherwise = super self # countInvocationsUpto (start + 1)
limit
+
+$(declareClass "HaskellSubclassOfObjectUsingSuper" "HaskellObjectUsingSuper")
+
+$(exportClass "HaskellSubclassOfObjectUsingSuper" "noMembers_" [])
+
tests = test [
"NSNumber" ~: test [
"alloc-initWithInt-intValue" ~: (assertNoLeaks $ do
@@ -172,7 +196,10 @@
initializeClass_HaskellObjectWithOutlet
initializeClass_HaskellObjectWithDescription
initializeClass_HaskellObjectWithIVar
- initializeClass_ExceptionThrower,
+ initializeClass_ExceptionThrower
+ initializeClass_HaskellObjectCountingInvocations
+ initializeClass_HaskellObjectUsingSuper
+ initializeClass_HaskellSubclassOfObjectUsingSuper,
"HaskellObjectWithOutlet" ~: test [
"alloc-init" ~: (assertNoLeaks $ do
@@ -235,11 +262,30 @@
result @?= expected
)
],
- "Super" ~: (assertNoLeaks $ do
- hobj <- _HaskellObjectWithDescription # alloc >>= init
- str <- hobj # description
- fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
- ),
+ "Super" ~: test [
+ "description" ~: (assertNoLeaks $ do
+ hobj <- _HaskellObjectWithDescription # alloc >>= init
+ str <- hobj # description
+ fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
+ ),
+ "chaining" ~: test [
+ "base" ~: (assertNoLeaks $ do
+ hobj <- _HaskellObjectCountingInvocations # alloc >>=
init
+ count <- hobj # countInvocationsUpto 0 100
+ count @?= 1
+ ),
+ "subclass" ~: (assertNoLeaks $ do
+ hobj <- _HaskellObjectUsingSuper # alloc >>= init
+ count <- hobj # countInvocationsUpto 0 100
+ count @?= 2
+ ),
+ "subsubclass" ~: (assertNoLeaks $ do
+ hobj <- _HaskellSubclassOfObjectUsingSuper # alloc >>=
init
+ count <- hobj # countInvocationsUpto 0 100
+ count @?= 2
+ )
+ ]
+ ],
"structs" ~: test [
"pointArg" ~: (do
let point = NSPoint 6.42 7.42
|
|
From: <cod...@go...> - 2008-12-09 21:52:44
|
Author: jam...@us...
Date: Tue Dec 9 13:10:33 2008
New Revision: 370
Modified:
branches/objc2/hoc/HOC_cbits/Exceptions.m
Log:
(objc2 branch) fixed a backward-compatibility issue I previously noted but
forgot to fix
Modified: branches/objc2/hoc/HOC_cbits/Exceptions.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Exceptions.m (original)
+++ branches/objc2/hoc/HOC_cbits/Exceptions.m Tue Dec 9 13:10:33 2008
@@ -64,8 +64,11 @@
clsHOCHaskellException = getClassByName("HOCHaskellException");
stablePtrIvar = class_getInstanceVariable(clsHOCHaskellException,
hsExceptionIvarName);
- #warning TODO - ivar_getOffset needs backport or workaround for
fact that offsets are no longer in the list
+#ifdef __OBJC2__
stablePtrOffset = ivar_getOffset(stablePtrIvar);
+#else
+ stablePtrOffset = stablePtrIvar->ivar_offset;
+#endif
selExceptionWithNameReasonUserInfo =
getSelectorForName("exceptionWithName:reason:userInfo:");
|
|
From: <cod...@go...> - 2008-12-09 21:28:53
|
Author: jam...@us...
Date: Tue Dec 9 13:12:04 2008
New Revision: 371
Modified:
branches/objc2/hoc/HOC_cbits/Ivars.m
branches/objc2/hoc/HOC_cbits/NewClass.h
Log:
(objc2 branch) Removed last 2 sources of build warnings in cbits. (yes, I
did proofread before removing the TODO ;-))
Modified: branches/objc2/hoc/HOC_cbits/Ivars.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Ivars.m (original)
+++ branches/objc2/hoc/HOC_cbits/Ivars.m Tue Dec 9 13:12:04 2008
@@ -59,7 +59,6 @@
list->ivar_list[i].ivar_offset = offset;
}
-#warning TODO - proofread buildIndexedIvarList
struct objc_ivar_list * buildIndexedIvarList(
struct hoc_ivar_list *list,
int start_offset,
Modified: branches/objc2/hoc/HOC_cbits/NewClass.h
==============================================================================
--- branches/objc2/hoc/HOC_cbits/NewClass.h (original)
+++ branches/objc2/hoc/HOC_cbits/NewClass.h Tue Dec 9 13:12:04 2008
@@ -7,7 +7,7 @@
struct hoc_ivar_list;
struct hoc_method_list;
-void newClass(struct objc_class * super_class,
+void newClass(Class super_class,
const char * name, /* never
deallocate this */
struct hoc_ivar_list *ivars,
struct hoc_method_list *methods,
|
|
From: <cod...@go...> - 2008-12-09 21:24:52
|
Author: jam...@us...
Date: Tue Dec 9 12:29:11 2008
New Revision: 368
Modified:
trunk/hoc/HOC/HOC.hs
trunk/hoc/HOC/HOC/Class.hs
trunk/hoc/HOC/HOC/DeclareClass.hs
trunk/hoc/HOC/HOC/NewlyAllocated.hs
trunk/hoc/HOC/HOC/Super.hs
trunk/hoc/Tests/TestFoundation.hs
Log:
Fixed super calls to chain properly (Issue 9) and added tests for the fix.
The short story:
- Added a typeclass "StaticClassAndObject" with a
method "staticClassForObject", and added an instance declaration to the
output of declareClass.
- Added a field to the SuperTarget and NewSuper constructors to carry the
targeted superclass, and changed the objc_super marshalling stuff in
Super.hs to make use of those fields.
Modified: trunk/hoc/HOC/HOC.hs
==============================================================================
--- trunk/hoc/HOC/HOC.hs (original)
+++ trunk/hoc/HOC/HOC.hs Tue Dec 9 12:29:11 2008
@@ -5,6 +5,9 @@
Object(..),
Class,
ClassAndObject,
+ StaticClassAndObject,
+ staticClassForObject,
+ staticSuperclassForObject,
( # ), ( #. ),
withExportedArray,
castObject,
@@ -36,6 +39,7 @@
SuperClass,
SuperTarget,
super,
+ castSuper,
CEnum(..),
declareCEnum,
Modified: trunk/hoc/HOC/HOC/Class.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Class.hs (original)
+++ trunk/hoc/HOC/HOC/Class.hs Tue Dec 9 12:29:11 2008
@@ -35,3 +35,14 @@
class (Object a, Object b) => ClassAndObject a b | a -> b, b -> a
instance ClassAndObject (Class a) (ID a)
+
+class ClassAndObject a b => StaticClassAndObject a b
+ where
+ -- _staticClassForObject must not touch its parameter:
+ -- its value should only depend on the type of the parameter.
+ _staticClassForObject :: b -> a
+
+-- make an export-safe version; don't want people making new
+-- implementations, but they should be allowed to use the info.
+staticClassForObject :: StaticClassAndObject a b => b -> a
+staticClassForObject = _staticClassForObject
\ No newline at end of file
Modified: trunk/hoc/HOC/HOC/DeclareClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/DeclareClass.hs (original)
+++ trunk/hoc/HOC/HOC/DeclareClass.hs Tue Dec 9 12:29:11 2008
@@ -45,7 +45,12 @@
valD (return $ VarP (mkName superName)) (normalB $ stringE super)
[],
-- instance SuperClass (name ()) (super ())
- instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`
superType) []
+ instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`
superType) [],
+
+ -- instance StaticClassAndObject (name ())
+ -- where staticClassForObject _ = classObject
+ instanceD (cxt []) (conT ''StaticClassAndObject `appT` metaClsType
`appT` clsType)
+ [funD '_staticClassForObject [clause [wildP] (normalB $ varE
(mkName classObjectName)) []]]
]
where
phantomName = name ++ "_"
@@ -56,5 +61,6 @@
classObjectName = "_" ++ name
superName = "super_" ++ name
+ metaClsType = conT (mkName metaClassName) `appT` [t| () |]
clsType = conT (mkName name) `appT` [t| () |]
superType = conT (mkName super) `appT` [t| () |]
Modified: trunk/hoc/HOC/HOC/NewlyAllocated.hs
==============================================================================
--- trunk/hoc/HOC/HOC/NewlyAllocated.hs (original)
+++ trunk/hoc/HOC/HOC/NewlyAllocated.hs Tue Dec 9 12:29:11 2008
@@ -14,6 +14,8 @@
import HOC.Base ( ObjCObject )
import HOC.Arguments ( ObjCArgument(..) )
+import HOC.Class
+import HOC.ID
import HOC.MessageTarget( Object(..), MessageTarget(..) )
import HOC.MsgSend
import HOC.Super
@@ -24,15 +26,16 @@
data NewlyAllocated a
= NewlyAllocated (Ptr ObjCObject)
- | NewSuper (Ptr ObjCObject)
+ | NewSuper (Ptr ObjCObject) (Class ())
instance ObjCArgument (NewlyAllocated a) (Ptr ObjCObject) where
withExportedArgument (NewlyAllocated p) action = action p
- withExportedArgument (NewSuper p) action =
- withExportedSuper p action
+ withExportedArgument (NewSuper p cls) action =
+ withExportedArgument cls $ \cls ->
+ withExportedSuper p cls action
exportArgument (NewlyAllocated p) = return p
- exportArgument (NewSuper p) = fail "HOC.NewlyAllocated.NewSuper:
exportArgument"
+ exportArgument (NewSuper p cls) = fail "HOC.NewlyAllocated.NewSuper:
exportArgument"
importArgument p = return (NewlyAllocated p)
@@ -45,13 +48,16 @@
instance MessageTarget (NewlyAllocated a) where
isNil (NewlyAllocated p) = p == nullPtr
- isNil (NewSuper p) = p == nullPtr
+ isNil (NewSuper p cls) = (p == nullPtr) || isNil cls
sendMessageWithRetval (NewlyAllocated _) = objSendMessageWithRetval
- sendMessageWithRetval (NewSuper _) = superSendMessageWithRetval
+ sendMessageWithRetval (NewSuper _ _) = superSendMessageWithRetval
sendMessageWithoutRetval (NewlyAllocated _) =
objSendMessageWithoutRetval
- sendMessageWithoutRetval (NewSuper _) = superSendMessageWithoutRetval
+ sendMessageWithoutRetval (NewSuper _ _) = superSendMessageWithoutRetval
-instance SuperClass sub super
- => Super (NewlyAllocated sub) (NewlyAllocated super) where
- super (NewlyAllocated x) = NewSuper x
+instance (SuperClass sub (ID super), StaticClassAndObject (Class super)
(ID super))
+ => Super (NewlyAllocated sub) (NewlyAllocated (ID super)) where
+ super na@(NewlyAllocated x) = NewSuper x (castObject superClass)
+ where superClass = staticClassForObject (asSuper na)
+ asSuper :: SuperClass sub super => NewlyAllocated sub ->
super
+ asSuper _ = error "staticClassForObject must not touch its
parameter"
Modified: trunk/hoc/HOC/HOC/Super.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Super.hs (original)
+++ trunk/hoc/HOC/HOC/Super.hs Tue Dec 9 12:29:11 2008
@@ -1,11 +1,14 @@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
- UndecidableInstances, FlexibleInstances #-}
+ UndecidableInstances, FlexibleInstances,
+ FlexibleContexts #-}
module HOC.Super(
- SuperClass, SuperTarget, Super(super), withExportedSuper
+ SuperClass, SuperTarget, Super(super), withExportedSuper,
+ staticSuperclassForObject, castSuper
) where
import HOC.Base
import HOC.Arguments
+import HOC.Class
import HOC.ID
import HOC.MsgSend
import HOC.MessageTarget
@@ -23,7 +26,7 @@
-- super, which is sufficient to define a class hierarchy.
class SuperClass sub super | sub -> super
-data SuperTarget a = SuperTarget a
+data SuperTarget a = SuperTarget a (Class ())
class Super sub super | sub -> super where
super :: sub -> super
@@ -33,32 +36,39 @@
pokeSuper objcSuper obj cls
= pokeByteOff objcSuper 0 obj >> pokeByteOff objcSuper (sizeOf obj) cls
-withExportedSuper p action =
- getSuperClassForObject p >>= \cls ->
+withExportedSuper p cls action =
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 (SuperTarget obj cls) action =
+ withExportedArgument cls $ \cls ->
withExportedArgument obj $ \p ->
- withExportedSuper p action
+ withExportedSuper p cls action
exportArgument _ = fail "HOC.Super: exportArgument"
importArgument _ = fail "HOC.Super: importArgument"
objCTypeString _ = "@" -- well, close enough.
-instance (Object (ID sub), Object super, SuperClass (ID sub) super)
- => Super (ID sub) (SuperTarget super) where
- super obj = SuperTarget (fromID $ toID obj)
+castSuper :: SuperClass (ID sub) (ID super) => ID sub -> ID super
+castSuper = castObject
-getSuperClassForObject obj = do cls <- peekByteOff obj 0 :: IO (Ptr (Ptr
()))
- peekElemOff cls 1
+staticSuperclassForObject ::
+ ( SuperClass (ID sub) (ID super)
+ , StaticClassAndObject (Class super) (ID super)
+ ) => ID sub -> Class super
+staticSuperclassForObject = staticClassForObject . castSuper
+
+instance (Object (ID sub), Object (ID super), SuperClass (ID sub) (ID
super),
+ StaticClassAndObject (Class super) (ID super))
+ => Super (ID sub) (SuperTarget (ID super)) where
+ super obj = SuperTarget (fromID $ toID obj) (castObject
(staticSuperclassForObject obj))
instance MessageTarget a => MessageTarget (SuperTarget a) where
- isNil (SuperTarget x) = isNil x
+ isNil (SuperTarget x cls) = isNil x || isNil cls
sendMessageWithRetval _ = superSendMessageWithRetval
sendMessageWithoutRetval _ = superSendMessageWithoutRetval
Modified: trunk/hoc/Tests/TestFoundation.hs
==============================================================================
--- trunk/hoc/Tests/TestFoundation.hs (original)
+++ trunk/hoc/Tests/TestFoundation.hs Tue Dec 9 12:29:11 2008
@@ -90,6 +90,30 @@
nil
>>= raise
+$(declareSelector "countInvocations:upto:" [t| Int -> Int -> IO Int |])
+
+$(declareClass "HaskellObjectCountingInvocations" "NSObject")
+$(exportClass "HaskellObjectCountingInvocations" "hoci_1_" [
+ InstanceMethod 'countInvocationsUpto
+ ])
+
+instance Has_countInvocationsUpto (HaskellObjectCountingInvocations a)
+
+hoci_1_countInvocationsUpto start limit self = return (start + 1)
+
+$(declareClass "HaskellObjectUsingSuper" "HaskellObjectCountingInvocations")
+$(exportClass "HaskellObjectUsingSuper" "hoci_2_" [
+ InstanceMethod 'countInvocationsUpto
+ ])
+
+hoci_2_countInvocationsUpto start limit self
+ | start >= limit = return start
+ | otherwise = super self # countInvocationsUpto (start + 1)
limit
+
+$(declareClass "HaskellSubclassOfObjectUsingSuper" "HaskellObjectUsingSuper")
+
+$(exportClass "HaskellSubclassOfObjectUsingSuper" "noMembers_" [])
+
tests = test [
"NSNumber" ~: test [
"alloc-initWithInt-intValue" ~: (assertNoLeaks $ do
@@ -172,7 +196,10 @@
initializeClass_HaskellObjectWithOutlet
initializeClass_HaskellObjectWithDescription
initializeClass_HaskellObjectWithIVar
- initializeClass_ExceptionThrower,
+ initializeClass_ExceptionThrower
+ initializeClass_HaskellObjectCountingInvocations
+ initializeClass_HaskellObjectUsingSuper
+ initializeClass_HaskellSubclassOfObjectUsingSuper,
"HaskellObjectWithOutlet" ~: test [
"alloc-init" ~: (assertNoLeaks $ do
@@ -235,11 +262,30 @@
result @?= expected
)
],
- "Super" ~: (assertNoLeaks $ do
- hobj <- _HaskellObjectWithDescription # alloc >>= init
- str <- hobj # description
- fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
- ),
+ "Super" ~: test [
+ "description" ~: (assertNoLeaks $ do
+ hobj <- _HaskellObjectWithDescription # alloc >>= init
+ str <- hobj # description
+ fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
+ ),
+ "chaining" ~: test [
+ "base" ~: (assertNoLeaks $ do
+ hobj <- _HaskellObjectCountingInvocations # alloc >>=
init
+ count <- hobj # countInvocationsUpto 0 100
+ count @?= 1
+ ),
+ "subclass" ~: (assertNoLeaks $ do
+ hobj <- _HaskellObjectUsingSuper # alloc >>= init
+ count <- hobj # countInvocationsUpto 0 100
+ count @?= 2
+ ),
+ "subsubclass" ~: (assertNoLeaks $ do
+ hobj <- _HaskellSubclassOfObjectUsingSuper # alloc >>=
init
+ count <- hobj # countInvocationsUpto 0 100
+ count @?= 2
+ )
+ ]
+ ],
"structs" ~: test [
"pointArg" ~: (do
let point = NSPoint 6.42 7.42
|
|
From: <cod...@go...> - 2008-12-08 21:04:50
|
Author: jam...@us...
Date: Mon Dec 8 13:03:47 2008
New Revision: 367
Modified:
branches/objc2/hoc/HOC_cbits/Class.h
branches/objc2/hoc/HOC_cbits/Class.m
branches/objc2/hoc/HOC_cbits/NewClass.m
Log:
Cleaned up recent objective C 2.0-related changes to newClass.
Modified: branches/objc2/hoc/HOC_cbits/Class.h
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Class.h (original)
+++ branches/objc2/hoc/HOC_cbits/Class.h Mon Dec 8 13:03:47 2008
@@ -1,4 +1,9 @@
#include <objc/objc.h>
id getClassByName(const char* name);
+
+Class getSuperclassForClass(Class class);
+Class getRootClassForClass(Class super_class);
+
+Class getClassForObject(id self);
Class getSuperClassForObject(id self);
Modified: branches/objc2/hoc/HOC_cbits/Class.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Class.m (original)
+++ branches/objc2/hoc/HOC_cbits/Class.m Mon Dec 8 13:03:47 2008
@@ -14,6 +14,42 @@
#endif
}
+Class getSuperclassForClass(Class class)
+{
+#ifdef GNUSTEP
+ if(CLS_ISRESOLV(class))
+ return class->super_class;
+ else
+ return getClassByName((const char*) class->super_class);
+
+#elif defined(__OBJC2__)
+ return class_getSuperclass(class);
+#else
+ return class->super_class;
+#endif
+}
+
+Class getRootClassForClass(Class super_class)
+{
+ Class root_class;
+
+ for(root_class = super_class;
+ getSuperclassForClass(root_class) != nil;
+ root_class = getSuperclassForClass(root_class))
+ ;
+
+ return root_class;
+}
+
+Class getClassForObject(id object)
+{
+#ifdef __OBJC2__
+ return object_getClass(object);
+#else
+ return object->isa;
+#endif
+}
+
Class getSuperClassForObject(id self)
{
#ifdef GNUSTEP
Modified: branches/objc2/hoc/HOC_cbits/NewClass.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/NewClass.m (original)
+++ branches/objc2/hoc/HOC_cbits/NewClass.m Mon Dec 8 13:03:47 2008
@@ -12,137 +12,132 @@
#define CLS_META _CLS_META
#endif
-static struct objc_class * getSuper(struct objc_class *class)
+static Class allocateClassPair(Class super_class, const char * name) {
+#ifdef __OBJC2__
+ return objc_allocateClassPair(super_class, name, 0);
+#else
+ Class new_class = calloc( 2, sizeof(struct objc_class) );
+ Class meta_class = &new_class[1];
+ Class root_class = getRootClassForClass(super_class);
+
+ new_class->isa = meta_class;
+ new_class->info = CLS_CLASS;
+ meta_class->info = CLS_META;
+
+ new_class->name = name;
+ meta_class->name = name;
+
+# ifdef GNUSTEP
+ new_class->super_class = (void*)(super_class->name);
+ meta_class->super_class = (void*)(super_class->isa->name);
+# else
+ new_class->super_class = super_class;
+ meta_class->super_class = super_class->isa;
+ meta_class->isa = (void *)root_class->isa;
+# endif
+
+ return new_class;
+#endif
+}
+
+static void registerClassPair(Class new_class) {
+#ifdef GNUSTEP
+ Module_t module = calloc(1, sizeof(Module));
+ Symtab_t symtab = calloc(1, sizeof(Symtab) + sizeof(void*) /* two defs
pointers */);
+ extern void __objc_exec_class (Module_t module);
+ extern void __objc_resolve_class_links ();
+
+ module->version = 8;
+ module->size = sizeof(Module);
+ module->name = strdup(name);
+ module->symtab = symtab;
+ symtab->cls_def_cnt = 1;
+ symtab->defs[0] = new_class;
+ symtab->defs[1] = NULL;
+
+ __objc_exec_class (module);
+ __objc_resolve_class_links();
+#elif defined(__OBJC2__)
+ objc_registerClassPair(new_class);
+#else
+ objc_addClass( new_class );
+#endif
+}
+
+static void addIvarsToClass(Class new_class, struct hoc_ivar_list *ivars)
+{
+#ifdef __OBJC2__
+ int i;
+
+ for (i = 0; i < ivars->ivar_count; i++)
+ {
+ struct hoc_ivar *ivar = &ivars->ivar_list[i];
+ class_addIvar(new_class, ivar->ivar_name,
+ ivar->ivar_size, ivar->ivar_alignment, ivar->ivar_types);
+ }
+#else
+ Class super_class = getSuperclassForClass(new_class);
+
+ int instance_size;
+ new_class->ivars = buildIndexedIvarList(
+ ivars,
+ super_class->instance_size,
+ &instance_size);
+
+ new_class->instance_size = super_class->instance_size + instance_size;
+#endif
+}
+
+static void addMethodsToClass(Class new_class, struct hoc_method_list
*methods)
{
#ifdef GNUSTEP
- if(CLS_ISRESOLV(class))
- return class->super_class;
- else
- return getClassByName((const char*) class->super_class);
-
+ class_add_method_list(new_class, convertMethodList(methods));
#elif defined(__OBJC2__)
- return class_getSuperclass(class);
+ int i;
+ for (i = 0; i < methods->method_count; i++)
+ {
+ struct hoc_method * m = &methods->method_list[i];
+ class_addMethod(new_class, m->method_name, m->method_imp,
m->method_types);
+ }
#else
- return class->super_class;
+ new_class->methodLists = calloc( 1, sizeof(struct objc_method_list *)
);
+ new_class->methodLists[0] = (struct objc_method_list*) -1;
+
+ class_addMethods(new_class, convertMethodList(methods));
#endif
}
-void newClass(struct objc_class * super_class,
+void newClass(Class super_class,
const char * name,
struct hoc_ivar_list *ivars,
struct hoc_method_list *methods,
struct hoc_method_list *class_methods)
{
- struct objc_class * meta_class;
- struct objc_class * new_class;
+ Class meta_class;
+ Class new_class;
assert(objc_lookUpClass(name) == nil);
/* Allocate the class and metaclass */
-#ifdef __OBJC2__
- new_class = objc_allocateClassPair(super_class, name, 0);
- meta_class = object_getClass(new_class);
-#else
- new_class = calloc( 2, sizeof(struct objc_class) );
- meta_class = &new_class[1];
-
- new_class->isa = meta_class;
- new_class->info = CLS_CLASS;
- meta_class->info = CLS_META;
-
- new_class->name = name;
- meta_class->name = name;
-#endif
+ new_class = allocateClassPair(super_class, name);
+ meta_class = getClassForObject(new_class);
/* Add instance variables to the class */
-#ifdef __OBJC2__
- {
- int i;
-
- for (i = 0; i < ivars->ivar_count; i++)
- {
- struct hoc_ivar *ivar = &ivars->ivar_list[i];
- class_addIvar(new_class, ivar->ivar_name,
- ivar->ivar_size, ivar->ivar_alignment, ivar->ivar_types);
- }
-
- }
-#else
- {
- int instance_size;
- new_class->ivars = buildIndexedIvarList(
- ivars,
- super_class->instance_size,
- &instance_size);
-
- new_class->instance_size = super_class->instance_size +
instance_size;
- }
-#endif
+ addIvarsToClass(new_class, ivars);
/* Add methods and class methods */
-#ifdef GNUSTEP
- new_class->super_class = (void*)(super_class->name);
- meta_class->super_class = (void*)(super_class->isa->name);
-
- {
- Module_t module = calloc(1, sizeof(Module));
- Symtab_t symtab = calloc(1, sizeof(Symtab) + sizeof(void*) /* two
defs pointers */);
- extern void __objc_exec_class (Module_t module);
- extern void __objc_resolve_class_links ();
-
- module->version = 8;
- module->size = sizeof(Module);
- module->name = strdup(name);
- module->symtab = symtab;
- symtab->cls_def_cnt = 1;
- symtab->defs[0] = new_class;
- symtab->defs[1] = NULL;
-
- __objc_exec_class (module);
- __objc_resolve_class_links();
- }
+ /* I don't know whether order actually matters here in the non-objc2
cases,
+ so I'm leaving it as it was. */
+#ifdef __OBJC2__
+ addMethodsToClass(new_class, methods);
+ addMethodsToClass(meta_class, class_methods);
- class_add_method_list(new_class, convertMethodList(methods));
- class_add_method_list(meta_class, convertMethodList(class_methods));
-#elif defined(__OBJC2__)
- {
- int i;
- for (i = 0; i < methods->method_count; i++)
- {
- struct hoc_method * m = &methods->method_list[i];
- class_addMethod(new_class, m->method_name, m->method_imp,
m->method_types);
- }
-
- for (i = 0; i < class_methods->method_count; i++)
- {
- struct hoc_method * m = &class_methods->method_list[i];
- class_addMethod(meta_class, m->method_name, m->method_imp,
m->method_types);
- }
-
- objc_registerClassPair(new_class);
- }
+ registerClassPair(new_class);
#else
- {
- struct objc_class * root_class;
- for(root_class = super_class;
- root_class->super_class != nil;
- root_class = getSuper(root_class))
- ;
-
- new_class->methodLists = calloc( 1, sizeof(struct objc_method_list *)
);
- meta_class->methodLists = calloc( 1, sizeof(struct objc_method_list
*) );
- new_class->methodLists[0] = (struct objc_method_list*) -1;
- meta_class->methodLists[0] = (struct objc_method_list*) -1;
-
- new_class->super_class = super_class;
- meta_class->super_class = super_class->isa;
- meta_class->isa = (void *)root_class->isa;
-
- objc_addClass( new_class );
-
- class_addMethods(new_class, convertMethodList(methods));
- class_addMethods(meta_class, convertMethodList(class_methods));
- }
+ registerClassPair(new_class);
+
+ addMethodsToClass(new_class, methods);
+ addMethodsToClass(meta_class, class_methods);
#endif
}
|
