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: Wolfgang T. <wth...@us...> - 2005-07-30 02:42:02
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23839/HOC Added Files: CEnum.hs Log Message: Improve Enum support (missing parts of the commit) --- NEW FILE: CEnum.hs --- module HOC.CEnum(CEnum(fromCEnum, toCEnum), declareCEnum, declareAnonymousCEnum) where import HOC.Arguments ( ObjCArgument(..) ) import HOC.TH import HOC.NameCaseChange import Foreign.C ( CInt ) class CEnum a where fromCEnum :: a -> CInt toCEnum :: CInt -> a declareCEnum name assocs = sequence $ [ dataD (cxt []) typ [] [ normalC n [] | n <- constructors ] [''Eq, ''Ord, ''Read, ''Show], instanceD (cxt []) (conT ''CEnum `appT` conT typ) {- -- this causes a strange problem that -- I didn't manage to reproduce yet. `whereQ` [d| fromCEnum = $(mkCaseMap $ zip (map (flip conP []) constructors) (map (litE . integerL) values)) toCEnum = $(mkCaseMap $ zip (map (litP . integerL) values) (map conE constructors)) |],-} [ valD (varP 'fromCEnum) (normalB $ mkCaseMap $ zip (map (flip conP []) constructors) (map (litE . integerL) values)) [], valD (varP 'toCEnum) (normalB $ mkCaseMap $ zip (map (litP . integerL) values) (map conE constructors)) [] ], instanceD (cxt []) (conT ''ObjCArgument `appT` conT typ `appT` [t| CInt |]) `whereQ` [d| exportArgument = return . fromCEnum importArgument = return . toCEnum objCTypeString _ = "i" |] ] ++ [ valD (varP constant) (normalB $ conE constructor) [] | (constant, constructor) <- zip constants constructors ] where typ = mkName $ nameToUppercase name constructors = map (mkName . nameToUppercase . fst) assocs constants = map (mkName . nameToLowercase . fst) assocs values = map snd assocs declareAnonymousCEnum assocs = sequence [ valD (varP constant) (normalB $ litE $ integerL value) [] | (constant, value) <- zip constants values ] where constants = map (mkName . nameToLowercase . fst) assocs values = map snd assocs mkCaseMap ps = [| \x -> $(caseE [|x|] $ map (\(a,b) -> match a (normalB b) []) ps) |] -- use Read and Show classes to avoid a GHC 6.4 bug: bug_1246483_workaround = read (show (42 :: Int)) :: Int |
|
From: Wolfgang T. <wth...@us...> - 2005-07-29 03:39:54
|
Update of /cvsroot/hoc/hoc/InterfaceGenerator In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5525/InterfaceGenerator Modified Files: CTypeToHaskell.hs Enums.hs ExportModule.hs PrepareDeclarations.hs Removed Files: NameCaseChange.hs Log Message: Improve Enum support (mostly untested) Index: ExportModule.hs =================================================================== RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/ExportModule.hs,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- ExportModule.hs 26 Jul 2005 01:29:58 -0000 1.6 +++ ExportModule.hs 29 Jul 2005 03:39:44 -0000 1.7 @@ -11,7 +11,8 @@ import Utils(groupByFirst) import Headers(ModuleName) import Enums(enumName, pprEnumType) -import NameCaseChange + +import HOC.NameCaseChange import Data.Set(setToList, unionManySets, mkSet, intersect) import qualified Data.HashTable as HashTable Index: PrepareDeclarations.hs =================================================================== RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/PrepareDeclarations.hs,v retrieving revision 1.11 retrieving revision 1.12 diff -u -d -r1.11 -r1.12 --- PrepareDeclarations.hs 31 Mar 2005 20:48:56 -0000 1.11 +++ PrepareDeclarations.hs 29 Jul 2005 03:39:44 -0000 1.12 @@ -12,8 +12,8 @@ import CTypeToHaskell import Headers(HeaderInfo(..), ModuleName) import Enums -import NameCaseChange +import HOC.NameCaseChange import HOC.SelectorNameMangling(mangleSelectorName) import Control.Monad(when) --- NameCaseChange.hs DELETED --- Index: CTypeToHaskell.hs =================================================================== RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/CTypeToHaskell.hs,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- CTypeToHaskell.hs 31 Mar 2005 20:46:13 -0000 1.5 +++ CTypeToHaskell.hs 29 Jul 2005 03:39:44 -0000 1.6 @@ -11,9 +11,10 @@ mentionedTypes) where import SyntaxTree -import NameCaseChange import Headers(ModuleName) +import HOC.NameCaseChange + import Control.Monad(when) import Data.FiniteMap import Data.Maybe(mapMaybe) Index: Enums.hs =================================================================== RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/Enums.hs,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- Enums.hs 5 Apr 2004 00:04:46 -0000 1.3 +++ Enums.hs 29 Jul 2005 03:39:44 -0000 1.4 @@ -7,9 +7,10 @@ import Headers(HeaderInfo(..), ModuleName) import SyntaxTree -import NameCaseChange import BindingScript ( BindingScript(bsHiddenEnums) ) +import HOC.NameCaseChange + import Data.Char ( toUpper ) import Data.Maybe ( mapMaybe ) import Data.FiniteMap ( FiniteMap, listToFM ) @@ -60,38 +61,16 @@ | otherwise = Just tag handleCType _ = Nothing -pprEnumType (EnumType (Just cname) constants) = - dataDeclaration $+$ instanceDeclaration - where - name = nameToUppercase cname - - dataDeclaration = text "data" <+> text name - <+> conDecls - conDecls = vcat $ zipWith (<+>) (equals : repeat (char '|')) - (map text constructors) - - - constructors = map (nameToUppercase . fst) constants - values = map snd constants - - - instanceDeclaration = - hang (text "instance ObjCArgument" - <+> text name <+> text "CInt where") - 4 - (exports $$ imports $$ typestr) - - exports = vcat [ text "exportArgument" <+> text con <+> text "= return" <+> hInteger val - | (con,val) <- zip constructors values ] - imports = vcat [ text "importArgument" <+> hInteger val <+> text "= return" <+> text con - | (con,val) <- zip constructors values ] - - hInteger i | i < 0 = parens (integer i) - | otherwise = integer i - - typestr = text "objCTypeString _ = \"i\"" - -pprEnumType (EnumType Nothing constants) = - text "{- ### anonymous enum!" - $$ nest 4 (pprEnumType $ EnumType (Just "Anon") constants) - $$ text "### -}" +pprEnumType (EnumType name constants) = + char '$' <> parens ( + declare + <+> brackets ( + hcat $ punctuate comma $ map pprAssoc constants + ) + ) + where + declare = case name of + Just cname -> text "declareCEnum" <+> doubleQuotes (text cname) + Nothing -> text "declareAnonymousCEnum" + pprAssoc (n, v) + = parens (doubleQuotes (text n) <> comma <+> integer v) |
|
From: Wolfgang T. <wth...@us...> - 2005-07-29 03:39:53
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5525/HOC/HOC Modified Files: Arguments.hs TH.hs Added Files: NameCaseChange.hs Log Message: Improve Enum support (mostly untested) Index: TH.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/TH.hs,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- TH.hs 6 Dec 2004 03:46:51 -0000 1.1 +++ TH.hs 29 Jul 2005 03:39:44 -0000 1.2 @@ -3,6 +3,7 @@ mkNameG_v, mkNameG_tc, mkNameG_d, + whereQ ) where import Language.Haskell.TH @@ -11,3 +12,8 @@ instance Functor Q where fmap f q = q >>= return . f +whereQ :: ([Q Dec] -> Q a) -> Q [Dec] -> Q a +header `whereQ` declsQ = do + decls <- declsQ + header (map return decls) + Index: Arguments.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Arguments.hs,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- Arguments.hs 26 Jul 2005 05:25:42 -0000 1.3 +++ Arguments.hs 29 Jul 2005 03:39:44 -0000 1.4 @@ -49,11 +49,6 @@ |] return [argInst] -whereQ :: ([Q Dec] -> Q a) -> Q [Dec] -> Q a -header `whereQ` declsQ = do - decls <- declsQ - header (map return decls) - -- to avoid overlapping instance ObjCIMPType (IO ()) below... data EvilDummyForUnit instance Storable EvilDummyForUnit where --- NEW FILE: NameCaseChange.hs --- module HOC.NameCaseChange where import Data.Char ( toUpper, toLower, isUpper ) nameToUppercase ('_':ame) = nameToUppercase ame nameToUppercase ('n':'s':n:ame) | isUpper n = 'N':'S':n:ame nameToUppercase (n:ame) = toUpper n : ame nameToLowercase ('N':'S':n:ame) | isUpper n = 'n':'s':n:ame nameToLowercase (n:ame) = toLower n : ame |
|
From: Wolfgang T. <wth...@us...> - 2005-07-29 03:39:52
|
Update of /cvsroot/hoc/hoc/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5525/HOC Modified Files: HOC.conf.in Log Message: Improve Enum support (mostly untested) Index: HOC.conf.in =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC.conf.in,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- HOC.conf.in 25 Jul 2005 03:59:25 -0000 1.2 +++ HOC.conf.in 29 Jul 2005 03:39:43 -0000 1.3 @@ -21,7 +21,9 @@ HOC.Utilities, HOC.ExportClass, HOC.NewClass, - HOC.Super + HOC.Super, + HOC.CEnum, + HOC.NameCaseChange hs-libraries: "HOC", "HOC_cbits" depends: base, template-haskell |
|
From: Wolfgang T. <wol...@gm...> - 2005-07-29 03:21:04
|
> Update of /cvsroot/hoc/hoc/AppKit > In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25073 > > Modified Files: > Makefile.in > Log Message: > Let the AppKit build system find the bindings for Foundation > > Why? The Foundation bindings should be installed in the inplace.conf file and found that way, did you have problems with that on your machine? Cheers, Wolfgang |
|
From: Andre P. <at...@us...> - 2005-07-28 08:30:10
|
Update of /cvsroot/hoc/hoc/AppKit In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25073 Modified Files: Makefile.in Log Message: Let the AppKit build system find the bindings for Foundation Index: Makefile.in =================================================================== RCS file: /cvsroot/hoc/hoc/AppKit/Makefile.in,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- Makefile.in 18 Apr 2005 00:45:43 -0000 1.10 +++ Makefile.in 28 Jul 2005 08:30:01 -0000 1.11 @@ -38,6 +38,7 @@ ln -sf ../Bindings/ifgen-output/Cocoa.hs . ln -sf ../Bindings/ifgen-output/AppKit.hs . ln -sf ../Bindings/ifgen-output/AppKit . + ln -sf ../Bindings/ifgen-output/Foundation . test ! -d ../Bindings/ifgen-output/GNUstepGUI || \ ln -sf ../Bindings/ifgen-output/GNUstepGUI . test ! -r ../Bindings/ifgen-output/GNUstepGUI.hs || \ |
|
From: Wolfgang T. <wth...@us...> - 2005-07-27 02:56:19
|
Update of /cvsroot/hoc/hoc/Samples/Browser In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16728/Browser Modified Files: Makefile Log Message: Use $(GHC) in Makefile Index: Makefile =================================================================== RCS file: /cvsroot/hoc/hoc/Samples/Browser/Makefile,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- Makefile 31 Mar 2005 15:46:49 -0000 1.5 +++ Makefile 27 Jul 2005 02:55:39 -0000 1.6 @@ -14,7 +14,7 @@ Browser: *.hs mkdir -p build - ghc --make -fglasgow-exts Main.hs -odir build -hidir build -O -o Browser + $(GHC) --make -fglasgow-exts Main.hs -odir build -hidir build -O -o Browser interpret: mkdir -p build @@ -24,7 +24,7 @@ nolink: mkdir -p build - ghc --make -fglasgow-exts Main.hs -odir build -hidir build -O -pgml true + $(GHC) --make -fglasgow-exts Main.hs -odir build -hidir build -O -pgml true Contents/Resources/all-selectors.txt: ../../Bindings/all-selectors.txt cp $< $@ |
|
From: Wolfgang T. <wth...@us...> - 2005-07-27 02:56:16
|
Update of /cvsroot/hoc/hoc/Samples/ExpressionParser In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16728/ExpressionParser Modified Files: Makefile Log Message: Use $(GHC) in Makefile Index: Makefile =================================================================== RCS file: /cvsroot/hoc/hoc/Samples/ExpressionParser/Makefile,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- Makefile 31 Mar 2005 15:46:50 -0000 1.3 +++ Makefile 27 Jul 2005 02:55:39 -0000 1.4 @@ -14,7 +14,7 @@ ExpressionParser: *.hs mkdir -p build - ghc --make Main.hs -odir build -hidir build -O -o $@ + $(GHC) --make Main.hs -odir build -hidir build -O -o $@ interpret: mkdir -p build @@ -24,7 +24,7 @@ nolink: mkdir -p build - ghc --make Main.hs -odir build -hidir build -O -pgml true + $(GHC) --make Main.hs -odir build -hidir build -O -pgml true clean: rm -rf build/ ExpressionParser ExpressionParser.app/ 'Interactive Haskell Application.app/' |
|
From: Wolfgang T. <wth...@us...> - 2005-07-27 02:56:15
|
Update of /cvsroot/hoc/hoc/Samples/UniqSort In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16728/UniqSort Modified Files: Makefile Log Message: Use $(GHC) in Makefile Index: Makefile =================================================================== RCS file: /cvsroot/hoc/hoc/Samples/UniqSort/Makefile,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- Makefile 1 Apr 2005 04:03:25 -0000 1.4 +++ Makefile 27 Jul 2005 02:55:40 -0000 1.5 @@ -9,10 +9,10 @@ all: uniqsort uniqsort: UniqSort.hs - ghc -o $@ --make $< + $(GHC) -o $@ --make $< uniqsort.stripped: UniqSort.hs - ghc -o $@ --make -optl-Wl,-dead_strip $< + $(GHC) -o $@ --make -optl-Wl,-dead_strip $< clean: -rm uniqsort *.o *.hi |
|
From: Wolfgang T. <wth...@us...> - 2005-07-27 02:54:02
|
Update of /cvsroot/hoc/hoc/Samples/Editor In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16498 Modified Files: Makefile Log Message: Use $(GHC) environment variable Index: Makefile =================================================================== RCS file: /cvsroot/hoc/hoc/Samples/Editor/Makefile,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- Makefile 31 Mar 2005 15:46:49 -0000 1.4 +++ Makefile 27 Jul 2005 02:53:54 -0000 1.5 @@ -14,7 +14,7 @@ Editor: *.hs mkdir -p build - ghc --make -fglasgow-exts Main.hs -odir build -hidir build -O -o Editor + $(GHC) --make -fglasgow-exts Main.hs -odir build -hidir build -O -o Editor interpret: mkdir -p build @@ -24,6 +24,6 @@ nolink: mkdir -p build - ghc --make -fglasgow-exts Main.hs -odir build -hidir build -O -pgml true + $(GHC) --make -fglasgow-exts Main.hs -odir build -hidir build -O -pgml true clean: rm -rf build Editor Editor.app 'Interpreted Haskell Application.app/' |
|
From: Wolfgang T. <wth...@us...> - 2005-07-27 02:52:29
|
Update of /cvsroot/hoc/hoc/Samples/Browser In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15737 Modified Files: TVUtilities.hs Log Message: import Prelude hiding(init), because we define an init method; due to recent changes, we need this even if we are only info_init and not init itself. Index: TVUtilities.hs =================================================================== RCS file: /cvsroot/hoc/hoc/Samples/Browser/TVUtilities.hs,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- TVUtilities.hs 3 Mar 2004 14:09:54 -0000 1.2 +++ TVUtilities.hs 27 Jul 2005 02:52:21 -0000 1.3 @@ -10,6 +10,7 @@ import HOC import Cocoa import AppKit.NSTableColumn(identifier) +import Prelude hiding(init) import Data.Array |
|
From: Wolfgang T. <wth...@us...> - 2005-07-27 02:36:19
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14092/HOC/HOC Modified Files: ID.hs MsgSend.hs NewlyAllocated.hs Super.hs Log Message: Make struct return values work. Index: MsgSend.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/MsgSend.hs,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- MsgSend.hs 25 Jul 2005 03:59:25 -0000 1.6 +++ MsgSend.hs 27 Jul 2005 02:36:09 -0000 1.7 @@ -1,10 +1,8 @@ {-# OPTIONS -cpp #-} module HOC.MsgSend( objSendMessageWithRetval, - objSendMessageWithStructRetval, objSendMessageWithoutRetval, superSendMessageWithRetval, - superSendMessageWithStructRetval, superSendMessageWithoutRetval ) where @@ -14,6 +12,7 @@ import HOC.Invocation import Foreign +import Control.Monad.Fix(mfix) objSendMessageWithRetval :: ObjCArgument a b @@ -21,12 +20,6 @@ -> Ptr (Ptr ()) -> IO a -objSendMessageWithStructRetval - :: ObjCArgument a b - => FFICif - -> Ptr (Ptr ()) - -> IO a - objSendMessageWithoutRetval :: FFICif -> Ptr (Ptr ()) @@ -38,12 +31,6 @@ -> Ptr (Ptr ()) -> IO a -superSendMessageWithStructRetval - :: ObjCArgument a b - => FFICif - -> Ptr (Ptr ()) - -> IO a - superSendMessageWithoutRetval :: FFICif -> Ptr (Ptr ()) @@ -61,9 +48,6 @@ imp <- objc_msg_lookup target selector callWithRetval cif imp args -objSendMessageWithStructRetval cif args = - objSendMessageWithRetval cif args - objSendMessageWithoutRetval cif args = do target <- peekElemOff args 0 >>= peek . castPtr selector <- peekElemOff args 1 >>= peek . castPtr @@ -74,31 +58,37 @@ #else + -- the type signatures are essentially bogus + -- the return value is not necessarily (), and might even be a struct. + -- we only call them via libffi, so we couldn't care less. foreign import ccall "MsgSend.h &objc_msgSend" objc_msgSendPtr :: FunPtr (Ptr ObjCObject -> SEL -> IO ()) foreign import ccall "MsgSend.h &objc_msgSend_stret" - objc_msgSend_stretPtr :: FunPtr (Ptr a -> Ptr ObjCObject -> SEL -> IO ()) + objc_msgSend_stretPtr :: FunPtr (Ptr ObjCObject -> SEL -> IO ()) foreign import ccall "MsgSend.h &objc_msgSendSuper" objc_msgSendSuperPtr :: FunPtr (Ptr ObjCObject -> SEL -> IO ()) foreign import ccall "MsgSend.h &objc_msgSendSuper_stret" - objc_msgSendSuper_stretPtr :: FunPtr (Ptr a -> Ptr ObjCObject -> SEL -> IO ()) + objc_msgSendSuper_stretPtr :: FunPtr (Ptr ObjCObject -> SEL -> IO ()) -objSendMessageWithRetval cif args = - callWithRetval cif objc_msgSendPtr args +withMarshalledDummy :: ObjCArgument a b => (b -> IO a) -> IO a +withMarshalledDummy action = action undefined -objSendMessageWithStructRetval cif args = - callWithRetval cif objc_msgSend_stretPtr args +objSendMessageWithRetval cif args = + withMarshalledDummy $ \dummy -> + callWithRetval cif (if isStructType dummy + then objc_msgSend_stretPtr + else objc_msgSendPtr) args objSendMessageWithoutRetval cif args = callWithoutRetval cif objc_msgSendPtr args superSendMessageWithRetval cif args = - callWithRetval cif objc_msgSendSuperPtr args - -superSendMessageWithStructRetval cif args = - callWithRetval cif objc_msgSendSuper_stretPtr args + withMarshalledDummy $ \dummy -> + callWithRetval cif (if isStructType dummy + then objc_msgSendSuper_stretPtr + else objc_msgSendSuperPtr) args superSendMessageWithoutRetval cif args = callWithoutRetval cif objc_msgSendSuperPtr args Index: NewlyAllocated.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/NewlyAllocated.hs,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- NewlyAllocated.hs 25 Jul 2005 03:59:25 -0000 1.3 +++ NewlyAllocated.hs 27 Jul 2005 02:36:09 -0000 1.4 @@ -37,5 +37,4 @@ isNil (NewlyAllocated p) = p == nullPtr sendMessageWithRetval _ = objSendMessageWithRetval - sendMessageWithStructRetval _ = objSendMessageWithStructRetval sendMessageWithoutRetval _ = objSendMessageWithoutRetval Index: Super.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Super.hs,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- Super.hs 25 Jul 2005 03:59:25 -0000 1.1 +++ Super.hs 27 Jul 2005 02:36:09 -0000 1.2 @@ -51,5 +51,4 @@ isNil (SuperTarget x) = isNil x sendMessageWithRetval _ = superSendMessageWithRetval - sendMessageWithStructRetval _ = superSendMessageWithStructRetval sendMessageWithoutRetval _ = superSendMessageWithoutRetval Index: ID.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/ID.hs,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- ID.hs 25 Jul 2005 03:59:25 -0000 1.8 +++ ID.hs 27 Jul 2005 02:36:09 -0000 1.9 @@ -39,12 +39,6 @@ -> Ptr (Ptr ()) -> IO ret - sendMessageWithStructRetval :: ObjCArgument ret b - => a - -> FFICif - -> Ptr (Ptr ()) - -> IO ret - sendMessageWithoutRetval :: a -> FFICif -> Ptr (Ptr ()) @@ -58,7 +52,6 @@ isNil x = x == nil sendMessageWithRetval _ = objSendMessageWithRetval - sendMessageWithStructRetval _ = objSendMessageWithStructRetval sendMessageWithoutRetval _ = objSendMessageWithoutRetval instance Object (ID a) where |
|
From: Wolfgang T. <wth...@us...> - 2005-07-27 02:36:19
|
Update of /cvsroot/hoc/hoc/Tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14092/Tests Modified Files: TestFoundation.hs Log Message: Make struct return values work. Index: TestFoundation.hs =================================================================== RCS file: /cvsroot/hoc/hoc/Tests/TestFoundation.hs,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- TestFoundation.hs 25 Jul 2005 03:59:26 -0000 1.4 +++ TestFoundation.hs 27 Jul 2005 02:36:09 -0000 1.5 @@ -155,11 +155,28 @@ result @?= expected ) ], - "Description" ~: (assertNoLeaks $ do + "Super" ~: (assertNoLeaks $ do hobj <- _HaskellObjectWithDescription # alloc >>= init str <- hobj # description fromNSString str @?= "<HaskellObjectWithDescription: TEST>" - ) + ), + "structs" ~: test [ + "point" ~: (do + let point = NSPoint 6.42 7.42 + result <- _NSValue # valueWithPoint point >>= pointValue + result @?= point + ), + "size" ~: (do + let size = NSSize 6.42 7.42 + result <- _NSValue # valueWithSize size >>= sizeValue + result @?= size + ), + "rect" ~: (do + let rect = NSRect (NSPoint 1 2) (NSSize 3 4) + result <- _NSValue # valueWithRect rect >>= rectValue + result @?= rect + ) + ] ] go = withAutoreleasePool $ runTestTT tests |
|
From: Wolfgang T. <wth...@us...> - 2005-07-26 05:25:51
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31094/HOC/HOC Modified Files: Class.hs DeclareSelector.hs Arguments.hs Log Message: Add a few NOINLINE pragmas to avoid bloating the code when compiling with -O. Basically, nothing that's used from declareSelector or declareClass should be inlined. Index: DeclareSelector.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- DeclareSelector.hs 26 Jul 2005 03:11:43 -0000 1.10 +++ DeclareSelector.hs 26 Jul 2005 05:25:42 -0000 1.11 @@ -29,6 +29,17 @@ $(makeMarshallers 4) marshallersUpTo = 4 +{-# NOINLINE method0 #-} +{-# NOINLINE method0_ #-} +{-# NOINLINE method1 #-} +{-# NOINLINE method1_ #-} +{-# NOINLINE method2 #-} +{-# NOINLINE method2_ #-} +{-# NOINLINE method3 #-} +{-# NOINLINE method3_ #-} +{-# NOINLINE method4 #-} +{-# NOINLINE method4_ #-} + $(makeCannedCIFs [ [t| ID () -> IO () |], [t| ID () -> IO (ID ()) |], Index: Arguments.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Arguments.hs,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- Arguments.hs 6 Dec 2004 03:46:51 -0000 1.2 +++ Arguments.hs 26 Jul 2005 05:25:42 -0000 1.3 @@ -97,6 +97,7 @@ let orderedArgs = (last args : sel : init args) ffiPrepCif ret orderedArgs +{-# NOINLINE getCifForSelector #-} -- might be called from generated code getCifForSelector sel = unsafePerformIO $ makeCifForSelector sel objCMethodType thing = ret ++ concat (last args : ":" : init args) Index: Class.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Class.hs,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -d -r1.1.1.1 -r1.2 --- Class.hs 27 Oct 2003 16:48:04 -0000 1.1.1.1 +++ Class.hs 26 Jul 2005 05:25:42 -0000 1.2 @@ -21,6 +21,7 @@ getClassByName name = withCString name c_getClassByName +{-# NOINLINE unsafeGetClassObject #-} -- called from generated code, save space unsafeGetClassObject name = unsafePerformIO $ getClassByName name >>= importImmortal |
|
From: Wolfgang T. <wth...@us...> - 2005-07-26 05:23:57
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30770/HOC/HOC Modified Files: SelectorMarshaller.hs Log Message: Add an evil {-# RULES #-} pragma to make the code smaller (removes unpackCString# from code generated for selectors) Index: SelectorMarshaller.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/SelectorMarshaller.hs,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- SelectorMarshaller.hs 26 Jul 2005 03:11:43 -0000 1.9 +++ SelectorMarshaller.hs 26 Jul 2005 05:23:48 -0000 1.10 @@ -17,6 +17,7 @@ import Foreign ( withArray, Ptr, nullPtr ) import System.IO.Unsafe ( unsafePerformIO ) +import GHC.Base ( unpackCString# ) import HOC.TH @@ -27,9 +28,24 @@ selectorInfoSel :: !SEL } +{-# NOINLINE mkSelectorInfo #-} mkSelectorInfo objCName hsName cif = SelectorInfo objCName hsName cif (getSelectorForName objCName) +{-# NOINLINE mkSelectorInfo# #-} +mkSelectorInfo# objCName# hsName# cif + -- NOTE: Don't call mkSelectorInfo here, the rule would apply! + = SelectorInfo objCName hsName cif (getSelectorForName objCName) + where + objCName = unpackCString# objCName# + hsName = unpackCString# hsName# + +{-# RULES +"litstr" forall s1 s2 cif. + mkSelectorInfo (unpackCString# s1) (unpackCString# s2) cif + = mkSelectorInfo# s1 s2 cif + #-} + makeMarshaller maybeInfoName haskellName nArgs isUnit isPure isRetained = funD haskellName [ clause (map varP $ infoArgument ++ map mkName arguments |
|
From: Wolfgang T. <wth...@us...> - 2005-07-26 05:22:34
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30672/HOC/HOC Modified Files: CannedCIFs.hs Log Message: remove debug output Index: CannedCIFs.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/CannedCIFs.hs,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- CannedCIFs.hs 26 Jul 2005 01:29:58 -0000 1.1 +++ CannedCIFs.hs 26 Jul 2005 05:22:18 -0000 1.2 @@ -8,13 +8,10 @@ import Data.List ( intersperse ) import Data.Maybe ( catMaybes ) import Data.Word ( Word ) -import Debug.Trace import Foreign ( Ptr ) import Foreign.C import Language.Haskell.TH -import System.IO - expandSynonyms typ = typ >>= flip expandSynonyms1 [] where @@ -30,7 +27,6 @@ expandSynonyms1 (ConT n) pending = do - runIO $ (print n >> hFlush stdout) info <- reify n case info of TyConI (TySynD _ args body) -> @@ -121,6 +117,5 @@ xt <- t case mbName of Just n | n `elem` ns - -> trace ("USING: " ++ n) $ varE $ mkNameG_v mod $ "cannedCIF_" ++ n - _ -> trace ("NOT USING: " ++ show mbName ++ " " ++ show xt) $ - [| getCifForSelector $( [| undefined |] `sigE` t) |] + -> varE $ mkNameG_v mod $ "cannedCIF_" ++ n + _ -> [| getCifForSelector $( [| undefined |] `sigE` t) |] |
|
From: Wolfgang T. <wth...@us...> - 2005-07-26 03:12:07
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9246/HOC/HOC Modified Files: DeclareSelector.hs ExportClass.hs SelectorMarshaller.hs Log Message: Further code size reductions: remove nArgs and isUnit from the SelectorInfo structure, we can calculate them from the (reified) type of the selector when we need them in exportClass. Additionally, wrap the SelectorInfo constructor in a function that also takes care of calling getSelectorForName. Index: SelectorMarshaller.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/SelectorMarshaller.hs,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- SelectorMarshaller.hs 25 Jul 2005 03:59:25 -0000 1.8 +++ SelectorMarshaller.hs 26 Jul 2005 03:11:43 -0000 1.9 @@ -1,5 +1,6 @@ module HOC.SelectorMarshaller( SelectorInfo(..), + mkSelectorInfo, makeMarshaller, makeMarshallers, marshallerName @@ -22,12 +23,13 @@ data SelectorInfo = SelectorInfo { selectorInfoObjCName :: String, selectorInfoHaskellName :: String, - selectorInfoCif :: FFICif, - selectorInfoSel :: SEL, - selectorInfoNArgs :: Int, - selectorInfoIsUnit :: Bool + selectorInfoCif :: !FFICif, + selectorInfoSel :: !SEL } +mkSelectorInfo objCName hsName cif + = SelectorInfo objCName hsName cif (getSelectorForName objCName) + makeMarshaller maybeInfoName haskellName nArgs isUnit isPure isRetained = funD haskellName [ clause (map varP $ infoArgument ++ map mkName arguments Index: DeclareSelector.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- DeclareSelector.hs 26 Jul 2005 01:29:58 -0000 1.9 +++ DeclareSelector.hs 26 Jul 2005 03:11:43 -0000 1.10 @@ -164,7 +164,7 @@ in valD (varP $ mkName $ infoName) (normalB [| let n = $(stringE name) - in SelectorInfo n + in mkSelectorInfo n $(if haskellName == name then [|n|] else stringE haskellName) @@ -172,10 +172,6 @@ "HOC.DeclareSelector" cannedCIFTypeNames (return $ simplifyType doctoredTypeSig)) - --(getCifForSelector $(e)) - (getSelectorForName n) - nArgs - isUnit |]) [], -- type $(imptypeName) target inst = arg1 -> arg2 -> target -> IO result Index: ExportClass.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/ExportClass.hs,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- ExportClass.hs 31 Mar 2005 20:44:08 -0000 1.7 +++ ExportClass.hs 26 Jul 2005 03:11:43 -0000 1.8 @@ -157,14 +157,29 @@ map (noBindS . exportMethod isClassMethod objCMethodList) (zip methods [firstIdx..]) - exportMethod isClassMethod objCMethodList (ImplementedMethod selectorInfo methodDefinition,num) = + exportMethod isClassMethod objCMethodList + (ImplementedMethod selectorInfo methodDefinition,num) + = do + VarI _ t _ _ <- reify $ mkName selName + let arrowsToList (AppT (AppT ArrowT a) b) + = a : arrowsToList b + arrowsToList (AppT (ConT c) b) + | c == ''IO + = [b] + arrowsToList (ForallT _ _ a) + = arrowsToList a + ts = arrowsToList t + + nArgs = length ts - 2 -- subtract target and result + isUnit = last ts == ConT ''() + exportMethod' isClassMethod objCMethodList num methodBody nArgs isUnit impTypeName selExpr cifExpr where methodBody = varE $ mkName methodDefinition selName = selectorInfoHaskellName selectorInfo - nArgs = selectorInfoNArgs selectorInfo - isUnit = selectorInfoIsUnit selectorInfo + -- nArgs = selectorInfoNArgs selectorInfo + -- isUnit = selectorInfoIsUnit selectorInfo impTypeName = mkName $ "ImpType_" ++ selName selExpr = [| selectorInfoSel $(varE $ mkName $ "info_" ++ selName) |] |
|
From: Wolfgang T. <wth...@us...> - 2005-07-26 01:30:07
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25095/HOC/HOC Modified Files: DeclareClass.hs DeclareSelector.hs Added Files: CannedCIFs.hs Log Message: Further reduce code size by using "canned" CIFs instead of always calling the overloaded getCifForSelector Index: DeclareClass.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareClass.hs,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- DeclareClass.hs 25 Jul 2005 03:59:25 -0000 1.4 +++ DeclareClass.hs 26 Jul 2005 01:29:58 -0000 1.5 @@ -13,7 +13,11 @@ declareClass name super = sequence $ [ -- data $(phantomName) a - dataD (cxt []) (mkName phantomName) [mkName "a"] [] [], + dataD (cxt []) (mkName phantomName) [mkName "a"] + -- the constructor is only here to work around + -- GHC sourceforge bug #1244882. + [return $ NormalC (mkName (phantomName ++ "dummy")) []] + [], -- type $(name) a = $(super) ($(phantomName) a) tySynD (mkName name) [mkName "a"] --- NEW FILE: CannedCIFs.hs --- module HOC.CannedCIFs where import HOC.Base ( SEL ) import HOC.Arguments ( getCifForSelector ) import HOC.ID ( ID ) import HOC.TH ( mkNameG_v ) import Data.List ( intersperse ) import Data.Maybe ( catMaybes ) import Data.Word ( Word ) import Debug.Trace import Foreign ( Ptr ) import Foreign.C import Language.Haskell.TH import System.IO expandSynonyms typ = typ >>= flip expandSynonyms1 [] where expandSynonyms1 (AppT a b) pending = do b' <- expandSynonyms1 b [] expandSynonyms1 a (b' : pending) expandSynonyms1 (ForallT vars ctx t) pending = do t' <- expandSynonyms1 t [] return $ foldl AppT t' pending expandSynonyms1 (ConT n) pending = do runIO $ (print n >> hFlush stdout) info <- reify n case info of TyConI (TySynD _ args body) -> expandSynonyms1 (substTy taken body) rest where taken = zip args pending rest = drop (length taken) pending _ -> return $ foldl AppT (ConT n) pending expandSynonyms1 other pending -- VarT, TupleT, ArrowT, ListT = return $ foldl AppT other pending substTy mapping (ForallT names cxt t) = ForallT names cxt (substTy mapping' t) where mapping' = filter (not . (`elem` names) . fst) mapping substTy mapping (VarT name) = case lookup name mapping of Just t -> t Nothing -> VarT name substTy mapping (AppT a b) = AppT (substTy mapping a) (substTy mapping b) substTy _ other = other toplevelConstructor (AppT a b) = toplevelConstructor a toplevelConstructor (ConT n) = Just n toplevelConstructor _ = Nothing repTypeName t = case toplevelConstructor t of Just t | t == ''ID -> Just ptr | t == ''SEL -> Just ptr | t == ''Ptr -> Just ptr | t == ''CInt -> Just int | t == ''CUInt -> Just int | t == ''Int -> Just hInt | t == ''Word -> Just hInt | t == ''() -> Just "void" | t == ''CChar -> Just "char" | t == ''CUChar -> Just "char" | t == ''CShort -> Just "short" | t == ''CUShort -> Just "short" | t == ''CLLong -> Just "llong" | t == ''CULLong -> Just "llong" | t == ''Float -> Just "float" | t == ''Double -> Just "double" | t == ''Bool -> Just "char" _ -> Nothing where ptr = "word" int = "word" -- ### NOT TRUE FOR 64 BITS hInt = "word" getCifTypeName qt = do t <- expandSynonyms qt let arrowsToList (AppT (AppT ArrowT a) b) = a : arrowsToList b arrowsToList (AppT (ConT c) b) | c == ''IO = [b] return $ fmap (concat . intersperse "_") $ mapM repTypeName $ arrowsToList t makeCannedCIFs types = do mbCanned <- mapM (\t -> do {- Q -} mbName <- getCifTypeName t return $ (mbName >>= Just . makeCannedCIF t)) types let (names, decls) = unzip $ catMaybes mbCanned decss <- sequence decls typeListDec <- [d| cannedCIFTypeNames = $(listE $ map stringE names) |] return $ typeListDec ++ concat decss where makeCannedCIF t n = (n, sequence [valD (varP $ cannedCIFName n) (normalB [| getCifForSelector $(e) |]) []] ) where e = [| undefined |] `sigE` t cannedCIFName n = mkName $ "cannedCIF_" ++ n staticCifForSelectorType mod ns t = do mbName <- getCifTypeName t xt <- t case mbName of Just n | n `elem` ns -> trace ("USING: " ++ n) $ varE $ mkNameG_v mod $ "cannedCIF_" ++ n _ -> trace ("NOT USING: " ++ show mbName ++ " " ++ show xt) $ [| getCifForSelector $( [| undefined |] `sigE` t) |] Index: DeclareSelector.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- DeclareSelector.hs 25 Jul 2005 03:59:25 -0000 1.8 +++ DeclareSelector.hs 26 Jul 2005 01:29:58 -0000 1.9 @@ -12,6 +12,7 @@ import HOC.ID import HOC.NewlyAllocated(NewlyAllocated) import HOC.Super +import HOC.CannedCIFs import Data.Char(isUpper, toLower, toUpper) import Data.Maybe(fromMaybe) @@ -28,6 +29,28 @@ $(makeMarshallers 4) marshallersUpTo = 4 +$(makeCannedCIFs [ + [t| ID () -> IO () |], + [t| ID () -> IO (ID ()) |], + [t| ID () -> IO Bool |], + [t| ID () -> IO Float |], + [t| ID () -> IO Double |], + [t| ID () -> ID () -> IO () |], + [t| ID () -> ID () -> IO (ID ()) |], + [t| Bool -> ID () -> IO () |], + [t| Float -> ID () -> IO () |], + [t| Double -> ID () -> IO () |], + [t| ID () -> ID () -> IO Bool |], + [t| ID () -> ID () -> IO Float |], + [t| ID () -> ID () -> IO Double |], + [t| ID () -> ID () -> ID () -> IO () |], + [t| ID () -> ID () -> ID () -> IO (ID ()) |], + [t| ID () -> ID () -> ID () -> IO Bool |], + [t| ID () -> ID () -> ID () -> ID () -> IO () |], + [t| ID () -> ID () -> ID () -> ID () -> IO (ID ()) |], + [t| ID () -> ID () -> ID () -> ID () -> IO Bool |] + ]) + declareRenamedSelector name haskellName typeSigQ = do typeSig <- typeSigQ @@ -145,7 +168,11 @@ $(if haskellName == name then [|n|] else stringE haskellName) - (getCifForSelector $(e)) + $(staticCifForSelectorType + "HOC.DeclareSelector" + cannedCIFTypeNames + (return $ simplifyType doctoredTypeSig)) + --(getCifForSelector $(e)) (getSelectorForName n) nArgs isUnit |
|
From: Wolfgang T. <wth...@us...> - 2005-07-26 01:30:07
|
Update of /cvsroot/hoc/hoc/InterfaceGenerator In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25095/InterfaceGenerator Modified Files: ExportModule.hs Log Message: Further reduce code size by using "canned" CIFs instead of always calling the overloaded getCifForSelector Index: ExportModule.hs =================================================================== RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/ExportModule.hs,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- ExportModule.hs 31 Mar 2005 15:30:19 -0000 1.5 +++ ExportModule.hs 26 Jul 2005 01:29:58 -0000 1.6 @@ -13,7 +13,7 @@ import Enums(enumName, pprEnumType) import NameCaseChange -import Data.Set hiding (map, null, filter, partition, empty) +import Data.Set(setToList, unionManySets, mkSet, intersect) import qualified Data.HashTable as HashTable import Data.List(nub, partition, isPrefixOf) import Data.Maybe(fromMaybe, catMaybes, mapMaybe, maybeToList, isNothing) @@ -314,7 +314,12 @@ groupImports thisModule = filter (\(mod, _) -> mod /= thisModule) . groupByFirst idsForClass :: String -> [String] -idsForClass name = [name, "_" ++ name, name ++ "Class", "super_" ++ name] +idsForClass name = [name, "_" ++ name, name ++ "Class", "super_" ++ name + -- we also need to export the phantom type + -- and a data constructor(!) for it, in order to + -- work around GHC bug #1244882. + , name ++ "_(..)" + ] idsForSel :: String -> [String] idsForSel name = [name, "Has_" ++ name, "info_" ++ name, "ImpType_" ++ name] |
|
From: Wolfgang T. <wth...@us...> - 2005-07-26 01:28:23
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24643/HOC/HOC Modified Files: StdArgumentTypes.hs Log Message: Bool should be marshalled as signed char, not int Index: StdArgumentTypes.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/StdArgumentTypes.hs,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- StdArgumentTypes.hs 1 Nov 2003 16:40:28 -0000 1.3 +++ StdArgumentTypes.hs 26 Jul 2005 01:27:44 -0000 1.4 @@ -19,7 +19,7 @@ $(declareStorableObjCArgument [t| SEL |] ":") -instance ObjCArgument Bool CInt where +instance ObjCArgument Bool CSChar where exportArgument False = return 0 exportArgument True = return 1 importArgument 0 = return False |
|
From: Wolfgang T. <wth...@us...> - 2005-07-25 03:59:35
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9095/HOC/HOC Modified Files: DeclareClass.hs DeclareSelector.hs ID.hs MsgSend.hs NewlyAllocated.hs SelectorMarshaller.hs Added Files: Super.hs Log Message: Implement sending messages to super. Objective-C: [super foo]; Haskell: super self # foo Index: SelectorMarshaller.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/SelectorMarshaller.hs,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- SelectorMarshaller.hs 6 Dec 2004 03:46:51 -0000 1.7 +++ SelectorMarshaller.hs 25 Jul 2005 03:59:25 -0000 1.8 @@ -64,11 +64,14 @@ collectArgs e = [| withArray $(listE (map varE marshalledArguments)) $(lamE [varP $ mkName "args"] e) |] - invoke | isUnit = [| sendMessageWithoutRetval (selectorInfoCif $(infoVar)) + invoke | isUnit = [| sendMessageWithoutRetval $(targetVar) + (selectorInfoCif $(infoVar)) $(argsVar)|] - | otherwise = [| sendMessageWithRetval (selectorInfoCif $(infoVar)) + | otherwise = [| sendMessageWithRetval $(targetVar) + (selectorInfoCif $(infoVar)) $(argsVar)|] where argsVar = varE $ mkName "args" + targetVar = varE $ mkName "target" purify e | isPure = [| unsafePerformIO $(e) |] | otherwise = e Index: DeclareClass.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareClass.hs,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- DeclareClass.hs 23 Jul 2005 06:26:17 -0000 1.3 +++ DeclareClass.hs 25 Jul 2005 03:59:25 -0000 1.4 @@ -3,6 +3,7 @@ import HOC.Base import HOC.Arguments import HOC.Class +import HOC.Super import HOC.TH @@ -34,7 +35,10 @@ (normalB [| unsafeGetClassObject $(stringE name) |]) [], -- $(superName) = "super" - valD (return $ VarP (mkName superName)) (normalB $ stringE super) [] + valD (return $ VarP (mkName superName)) (normalB $ stringE super) [], + + -- instance SuperClass (name ()) (super ()) + instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT` superType) [] ] where phantomName = name ++ "_" @@ -44,3 +48,6 @@ | otherwise = super ++ "Class" classObjectName = "_" ++ name superName = "super_" ++ name + + clsType = conT (mkName name) `appT` [t| () |] + superType = conT (mkName super) `appT` [t| () |] Index: MsgSend.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/MsgSend.hs,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- MsgSend.hs 13 May 2004 11:08:34 -0000 1.5 +++ MsgSend.hs 25 Jul 2005 03:59:25 -0000 1.6 @@ -1,8 +1,11 @@ -{-# OPTIONS -cpp -fvia-C #-} +{-# OPTIONS -cpp #-} module HOC.MsgSend( - sendMessageWithRetval, - sendMessageWithStructRetval, - sendMessageWithoutRetval + objSendMessageWithRetval, + objSendMessageWithStructRetval, + objSendMessageWithoutRetval, + superSendMessageWithRetval, + superSendMessageWithStructRetval, + superSendMessageWithoutRetval ) where import HOC.Base @@ -12,17 +15,39 @@ import Foreign -sendMessageWithRetval :: ObjCArgument a b - => FFICif - -> Ptr (Ptr ()) - -> IO a -sendMessageWithStructRetval :: ObjCArgument a b - => FFICif - -> Ptr (Ptr ()) - -> IO a -sendMessageWithoutRetval :: FFICif - -> Ptr (Ptr ()) - -> IO () +objSendMessageWithRetval + :: ObjCArgument a b + => FFICif + -> Ptr (Ptr ()) + -> IO a + +objSendMessageWithStructRetval + :: ObjCArgument a b + => FFICif + -> Ptr (Ptr ()) + -> IO a + +objSendMessageWithoutRetval + :: FFICif + -> Ptr (Ptr ()) + -> IO () + +superSendMessageWithRetval + :: ObjCArgument a b + => FFICif + -> Ptr (Ptr ()) + -> IO a + +superSendMessageWithStructRetval + :: ObjCArgument a b + => FFICif + -> Ptr (Ptr ()) + -> IO a + +superSendMessageWithoutRetval + :: FFICif + -> Ptr (Ptr ()) + -> IO () #ifdef GNUSTEP @@ -30,21 +55,23 @@ objc_msg_lookup :: Ptr ObjCObject -> SEL -> IO (FunPtr ()) -sendMessageWithRetval cif args = do +objSendMessageWithRetval cif args = do target <- peekElemOff args 0 >>= peek . castPtr selector <- peekElemOff args 1 >>= peek . castPtr imp <- objc_msg_lookup target selector callWithRetval cif imp args -sendMessageWithStructRetval cif args = - sendMessageWithRetval cif args +objSendMessageWithStructRetval cif args = + objSendMessageWithRetval cif args -sendMessageWithoutRetval cif args = do +objSendMessageWithoutRetval cif args = do target <- peekElemOff args 0 >>= peek . castPtr selector <- peekElemOff args 1 >>= peek . castPtr imp <- objc_msg_lookup target selector callWithoutRetval cif imp args +#error GNUSTEP unimplemented: send message to super + #else foreign import ccall "MsgSend.h &objc_msgSend" @@ -52,13 +79,28 @@ foreign import ccall "MsgSend.h &objc_msgSend_stret" objc_msgSend_stretPtr :: FunPtr (Ptr a -> Ptr ObjCObject -> SEL -> IO ()) -sendMessageWithRetval cif args = +foreign import ccall "MsgSend.h &objc_msgSendSuper" + objc_msgSendSuperPtr :: FunPtr (Ptr ObjCObject -> SEL -> IO ()) +foreign import ccall "MsgSend.h &objc_msgSendSuper_stret" + objc_msgSendSuper_stretPtr :: FunPtr (Ptr a -> Ptr ObjCObject -> SEL -> IO ()) + +objSendMessageWithRetval cif args = callWithRetval cif objc_msgSendPtr args -sendMessageWithStructRetval cif args = +objSendMessageWithStructRetval cif args = callWithRetval cif objc_msgSend_stretPtr args -sendMessageWithoutRetval cif args = +objSendMessageWithoutRetval cif args = callWithoutRetval cif objc_msgSendPtr args + +superSendMessageWithRetval cif args = + callWithRetval cif objc_msgSendSuperPtr args + +superSendMessageWithStructRetval cif args = + callWithRetval cif objc_msgSendSuper_stretPtr args + +superSendMessageWithoutRetval cif args = + callWithoutRetval cif objc_msgSendSuperPtr args + #endif Index: ID.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/ID.hs,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- ID.hs 6 Apr 2004 12:31:18 -0000 1.7 +++ ID.hs 25 Jul 2005 03:59:25 -0000 1.8 @@ -3,6 +3,7 @@ import HOC.Base import HOC.Arguments import HOC.FFICallInterface(FFICif) +import HOC.MsgSend import Control.Concurrent.MVar import Control.Exception(evaluate,assert) @@ -32,13 +33,34 @@ class ObjCArgument a (Ptr ObjCObject) => MessageTarget a where isNil :: a -> Bool + sendMessageWithRetval :: ObjCArgument ret b + => a + -> FFICif + -> Ptr (Ptr ()) + -> IO ret + + sendMessageWithStructRetval :: ObjCArgument ret b + => a + -> FFICif + -> Ptr (Ptr ()) + -> IO ret + + sendMessageWithoutRetval :: a + -> FFICif + -> Ptr (Ptr ()) + -> IO () + class MessageTarget a => Object a where toID :: a -> ID () fromID :: ID () -> a instance MessageTarget (ID a) where isNil x = x == nil - + + sendMessageWithRetval _ = objSendMessageWithRetval + sendMessageWithStructRetval _ = objSendMessageWithStructRetval + sendMessageWithoutRetval _ = objSendMessageWithoutRetval + instance Object (ID a) where toID (ID a) = ID a toID Nil = Nil @@ -267,11 +289,9 @@ getHaskellDataForID (ID (HSO _ dat)) = dat -releaseExtraReference obj = do - case toID obj of - ID (HSO ptr _) -> releaseObject ptr - Nil -> return () - return obj +releaseExtraReference obj + = withExportedArgument obj (\ptr -> when (ptr /= nullPtr) (releaseObject ptr)) + >> return obj objectMapStatistics = alloca $ \pAllocated -> Index: DeclareSelector.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- DeclareSelector.hs 23 Jul 2005 06:26:17 -0000 1.7 +++ DeclareSelector.hs 25 Jul 2005 03:59:25 -0000 1.8 @@ -11,6 +11,7 @@ import HOC.StdArgumentTypes import HOC.ID import HOC.NewlyAllocated(NewlyAllocated) +import HOC.Super import Data.Char(isUpper, toLower, toUpper) import Data.Maybe(fromMaybe) @@ -155,9 +156,14 @@ (return $ makeImpType typeSig), -- class Object a => $(className) a - classD (cxt [conT (mkName "Object") `appT` varT (mkName "a")]) + classD (cxt [conT ''MessageTarget `appT` varT (mkName "a")]) (mkName className) [mkName "a"] [] [], + -- instance $(className) a => $(className) (SuperTarget a) + instanceD (cxt [conT (mkName className) `appT` varT (mkName "a")]) + (conT (mkName className) `appT` (conT ''SuperTarget `appT` varT (mkName "a"))) + [], + sigD (mkName haskellName) $ return doctoredTypeSig, if nArgs > marshallersUpTo || resultRetained Index: NewlyAllocated.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/NewlyAllocated.hs,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- NewlyAllocated.hs 6 Apr 2004 12:31:18 -0000 1.2 +++ NewlyAllocated.hs 25 Jul 2005 03:59:25 -0000 1.3 @@ -14,6 +14,7 @@ import HOC.Base ( ObjCObject ) import HOC.Arguments ( ObjCArgument(..) ) import HOC.ID ( Object(..), MessageTarget(..) ) +import HOC.MsgSend import Foreign.Ptr ( Ptr, nullPtr ) import System.IO.Unsafe ( unsafePerformIO ) @@ -34,3 +35,7 @@ instance MessageTarget (NewlyAllocated a) where isNil (NewlyAllocated p) = p == nullPtr + + sendMessageWithRetval _ = objSendMessageWithRetval + sendMessageWithStructRetval _ = objSendMessageWithStructRetval + sendMessageWithoutRetval _ = objSendMessageWithoutRetval --- NEW FILE: Super.hs --- module HOC.Super( SuperClass, SuperTarget, super ) where import HOC.Base import HOC.Arguments import HOC.ID import HOC.MsgSend import Foreign {- Messages to super. [super foo] is written as super self # foo -} class SuperClass sub super | sub -> super data SuperTarget a = SuperTarget a super :: (Object sub, Object super, SuperClass sub super) => sub -> SuperTarget super --- pokeSuper objcSuper obj cls = pokeByteOff objcSuper 0 obj >> pokeByteOff objcSuper (sizeOf obj) cls instance MessageTarget a => ObjCArgument (SuperTarget a) (Ptr ObjCObject) where withExportedArgument (SuperTarget obj) action = withExportedArgument obj $ \p -> getSuperClassForObject p >>= \cls -> allocaBytes (sizeOf p + sizeOf cls) $ \sptr -> pokeSuper sptr p cls >> action sptr exportArgument _ = fail "HOC.Super: exportArgument" importArgument _ = fail "HOC.Super: importArgument" objCTypeString _ = "@" -- well, close enough. super obj = SuperTarget (fromID $ toID obj) getSuperClassForObject obj = do cls <- peekByteOff obj 0 :: IO (Ptr (Ptr ())) peekElemOff cls 1 instance MessageTarget a => MessageTarget (SuperTarget a) where isNil (SuperTarget x) = isNil x sendMessageWithRetval _ = superSendMessageWithRetval sendMessageWithStructRetval _ = superSendMessageWithStructRetval sendMessageWithoutRetval _ = superSendMessageWithoutRetval |
|
From: Wolfgang T. <wth...@us...> - 2005-07-25 03:59:34
|
Update of /cvsroot/hoc/hoc/Tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9095/Tests Modified Files: TestFoundation.hs Log Message: Implement sending messages to super. Objective-C: [super foo]; Haskell: super self # foo Index: TestFoundation.hs =================================================================== RCS file: /cvsroot/hoc/hoc/Tests/TestFoundation.hs,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- TestFoundation.hs 31 Mar 2005 20:52:43 -0000 1.3 +++ TestFoundation.hs 25 Jul 2005 03:59:26 -0000 1.4 @@ -43,6 +43,18 @@ Outlet "otherObject" [t| ID () |] ]) + +$(declareClass "HaskellObjectWithDescription" "NSObject") + +$(exportClass "HaskellObjectWithDescription" "ho2_" [ + InstanceMethod info_description + ]) + +ho2_description self + = do + superDesc <- fmap fromNSString $ super self # description + return $ toNSString $ head (words superDesc) ++ " TEST>" + tests = test [ "NSNumber" ~: test [ "alloc-initWithInt-intValue" ~: (assertNoLeaks $ do @@ -142,11 +154,17 @@ expected <- try (fail "Message sent to nil: intValue") result @?= expected ) - ] + ], + "Description" ~: (assertNoLeaks $ do + hobj <- _HaskellObjectWithDescription # alloc >>= init + str <- hobj # description + fromNSString str @?= "<HaskellObjectWithDescription: TEST>" + ) ] go = withAutoreleasePool $ runTestTT tests main = do initializeClass_HaskellObjectWithOutlet + initializeClass_HaskellObjectWithDescription go |
|
From: Wolfgang T. <wth...@us...> - 2005-07-25 03:59:34
|
Update of /cvsroot/hoc/hoc/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9095/HOC Modified Files: HOC.conf.in HOC.hs Log Message: Implement sending messages to super. Objective-C: [super foo]; Haskell: super self # foo Index: HOC.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC.hs,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- HOC.hs 31 Mar 2005 20:44:10 -0000 1.9 +++ HOC.hs 25 Jul 2005 03:59:25 -0000 1.10 @@ -20,7 +20,7 @@ withAutoreleasePool, - isNil, + isNil, IVar, getIVar, @@ -33,6 +33,10 @@ NewlyAllocated, + SuperClass, + SuperTarget, + super, + -- debugging & statistics: objectMapStatistics @@ -51,3 +55,4 @@ import HOC.ExportClass import HOC.Utilities import HOC.NewlyAllocated +import HOC.Super Index: HOC.conf.in =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC.conf.in,v retrieving revision 1.1 retrieving revision 1.2 diff -u -d -r1.1 -r1.2 --- HOC.conf.in 18 Apr 2005 00:45:42 -0000 1.1 +++ HOC.conf.in 25 Jul 2005 03:59:25 -0000 1.2 @@ -20,7 +20,8 @@ HOC.MsgSend, HOC.Utilities, HOC.ExportClass, - HOC.NewClass + HOC.NewClass, + HOC.Super hs-libraries: "HOC", "HOC_cbits" depends: base, template-haskell |
|
From: Wolfgang T. <wth...@us...> - 2005-07-23 06:26:26
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv21860 Modified Files: DeclareClass.hs DeclareSelector.hs Log Message: Reduce code size by another 20%. When we use stringE rather than lifting a string into a quote, the unpackCString# optimisation does work. Index: DeclareClass.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareClass.hs,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- DeclareClass.hs 6 Dec 2004 03:46:51 -0000 1.2 +++ DeclareClass.hs 23 Jul 2005 06:26:17 -0000 1.3 @@ -34,7 +34,7 @@ (normalB [| unsafeGetClassObject $(stringE name) |]) [], -- $(superName) = "super" - valD (return $ VarP (mkName superName)) (normalB [| super |]) [] + valD (return $ VarP (mkName superName)) (normalB $ stringE super) [] ] where phantomName = name ++ "_" Index: DeclareSelector.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- DeclareSelector.hs 23 Jul 2005 06:09:26 -0000 1.6 +++ DeclareSelector.hs 23 Jul 2005 06:26:17 -0000 1.7 @@ -139,10 +139,11 @@ let e = [| undefined |] `sigE` (return $ simplifyType doctoredTypeSig) in valD (varP $ mkName $ infoName) (normalB [| - let n = name - hn = $(if haskellName == name then [|n|] else [|haskellName|]) + let n = $(stringE name) in SelectorInfo n - hn + $(if haskellName == name + then [|n|] + else stringE haskellName) (getCifForSelector $(e)) (getSelectorForName n) nArgs |
|
From: Wolfgang T. <wth...@us...> - 2005-07-23 06:10:09
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18966 Modified Files: DeclareSelector.hs Log Message: Reduce code size by about... *drum roll* ... 20%. The trick: common up duplicate uses of selector names using "let" in generated code. The strings take up way too much space because the unpackCString# optimisation in GHC doesn't work after the strings were passed through template Haskell, so duplicating them hurts. Index: DeclareSelector.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- DeclareSelector.hs 6 Dec 2004 03:46:51 -0000 1.5 +++ DeclareSelector.hs 23 Jul 2005 06:09:26 -0000 1.6 @@ -139,12 +139,14 @@ let e = [| undefined |] `sigE` (return $ simplifyType doctoredTypeSig) in valD (varP $ mkName $ infoName) (normalB [| - SelectorInfo name - haskellName - (getCifForSelector $(e)) - (getSelectorForName name) - nArgs - isUnit + let n = name + hn = $(if haskellName == name then [|n|] else [|haskellName|]) + in SelectorInfo n + hn + (getCifForSelector $(e)) + (getSelectorForName n) + nArgs + isUnit |]) [], -- type $(imptypeName) target inst = arg1 -> arg2 -> target -> IO result |
