Menu
▾
▴
[hoc-cvs] hoc/HOC/HOC ExternConstants.hs,NONE,1.1 ExternFunctions.hs,NONE,1.1 Dyld.hs,NONE,1.1 Exception.hs,NONE,1.1 Exception.hs-boot,NONE,1.1 Arguments.hs,1.4,1.5 ExportClass.hs,1.8,1.9 Invocation.hs,1.1.1.1,1.2
|
From: Wolfgang T. <wth...@us...> - 2005-09-27 11:55:38
|
Update of /cvsroot/hoc/hoc/HOC/HOC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12043/HOC/HOC Modified Files: Arguments.hs ExportClass.hs Invocation.hs Added Files: ExternConstants.hs ExternFunctions.hs Dyld.hs Exception.hs Exception.hs-boot Log Message: A monster commit, brought to you by the Greater Toronto Airport Authority and Czech Airlines. HOC now supports: * Marshalling of exceptions NSExceptions get marshalled into Haskell exceptions that can be caught using Foundation.NSException.catchNS. Haskell exceptions get wrapped in a (private) subclass of NSException and marshalled back if they re-enter Haskell land. * importing of extern constants $(declareExternConst "NSDeviceRGBColorSpace" [t| NSString () |]) * importing of global functions (e.g. NSRectFill) using HOC marshalling: $(declareExternFun "NSRectFill" [t| NSRect -> IO () |]) * ifgen generates constant & function declarations automatically from Foundation and AppKit headers. --- NEW FILE: ExternConstants.hs --- module HOC.ExternConstants(declareExternConst) where import HOC.TH import HOC.Arguments import HOC.NameCaseChange import HOC.Dyld import Foreign declareExternConst :: String -> TypeQ -> Q [Dec] declareExternConst name typ = sequence [ sigD n typ, valD (varP n) (normalB expr) [] ] where n = mkName $ nameToLowercase name expr = [| getGlobalVar $(stringE name) |] getGlobalVar name = unsafePerformIO $ lookupSymbol name >>= peek . castFunPtrToPtr >>= importArgument getGlobalVar# name# = unsafePerformIO $ lookupSymbol# name# >>= peek . castFunPtrToPtr >>= importArgument Index: ExportClass.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/ExportClass.hs,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- ExportClass.hs 26 Jul 2005 03:11:43 -0000 1.8 +++ ExportClass.hs 27 Sep 2005 11:55:22 -0000 1.9 @@ -16,6 +16,7 @@ import HOC.Class import HOC.NewClass import HOC.TH +import HOC.Exception data ClassMember = InstanceMethod SelectorInfo Index: Arguments.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Arguments.hs,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- Arguments.hs 29 Jul 2005 03:39:44 -0000 1.4 +++ Arguments.hs 27 Sep 2005 11:55:22 -0000 1.5 @@ -92,8 +92,17 @@ let orderedArgs = (last args : sel : init args) ffiPrepCif ret orderedArgs +makeCifForFunction fun = do + args <- objCImpGetArgsFFI fun + ret <- objCImpGetRetFFI fun + ffiPrepCif ret args + {-# NOINLINE getCifForSelector #-} -- might be called from generated code getCifForSelector sel = unsafePerformIO $ makeCifForSelector sel + +{-# NOINLINE getCifForFunction #-} -- might be called from generated code +getCifForFunction fun = unsafePerformIO $ makeCifForFunction fun + objCMethodType thing = ret ++ concat (last args : ":" : init args) where --- NEW FILE: Exception.hs --- module HOC.Exception where import Data.Typeable import Foreign import Foreign.C.String ( CString, withCString ) import Prelude hiding ( catch ) import Control.Exception ( evaluate, throwIO, throwDyn, catchDyn, catch ) import HOC.Base import HOC.Arguments import HOC.ID data WrappedNSException = WrappedNSException (ID ()) deriving Typeable foreign import ccall unsafe wrapHaskellException :: CString -> StablePtr a -> IO (Ptr ObjCObject) foreign import ccall unsafe unwrapHaskellException :: Ptr ObjCObject -> IO (StablePtr a) exceptionObjCToHaskell :: Ptr ObjCObject -> IO a exceptionObjCToHaskell exception = do sptr <- unwrapHaskellException exception if (castStablePtrToPtr sptr == nullPtr) then do exc <- importArgument exception evaluate $ throwDyn $ WrappedNSException exc else do exc <- deRefStablePtr sptr throwIO exc exceptionHaskellToObjC :: IO a -> IO (Ptr ObjCObject) exceptionHaskellToObjC action = (action >> return nullPtr) `catchDyn` (\(WrappedNSException exc) -> exportArgument exc) `catch` (\exc -> withCString (show exc) $ \cstr -> newStablePtr exc >>= wrapHaskellException cstr) --- NEW FILE: ExternFunctions.hs --- module HOC.ExternFunctions(declareExternFun) where import HOC.TH import HOC.Arguments import HOC.Invocation import HOC.Dyld import HOC.NameCaseChange import Foreign import System.IO.Unsafe declareExternFun :: String -> TypeQ -> Q [Dec] declareExternFun name typeSigQ = do typeSig <- typeSigQ let n = mkName $ nameToLowercase name cifN = mkName $ "cif__" ++ name ptrN = mkName $ "c__" ++ name -- ### FIXME: Code Duplication from SelectorMarshaller.hs arguments = [ "arg" ++ show i | i <- [1..nArgs] ] argumentsToMarshal = map (varE.mkName) arguments marshalledArguments = map (mkName . (++"'")) arguments marshallerBody = marshallArgs $ collectArgs $ invoke marshallArgs = marshallArgs' argumentsToMarshal marshalledArguments where marshallArgs' [] [] e = e marshallArgs' (arg:args) (arg':args') e = [| withMarshalledArgument $(arg) $(lamE [varP arg'] e') |] where e' = marshallArgs' args args' e collectArgs e = [| withArray $(listE (map varE marshalledArguments)) $(lamE [varP $ mkName "args"] e) |] invoke | isUnit = [| callWithoutRetval $(varE cifN) $(varE ptrN) $(varE $ mkName "args")|] | otherwise = [| callWithRetval $(varE cifN) $(varE ptrN) $(varE $ mkName "args")|] -- ### FIXME: Code Duplication from DeclareSelector.hs countArgs (ForallT vars ctxt ty) = countArgs ty countArgs ((ArrowT `AppT` _) `AppT` rest) = 1 + countArgs rest countArgs other = 0 resultType (ForallT vars ctxt ty) = resultType ty resultType ((ArrowT `AppT` _) `AppT` rest) = resultType rest resultType other = other (isPure, pureType) = case resultType typeSig of (ConT con) `AppT` ty | con == ''IO -> (False, ty) ty -> error $ name ++ " --- function type must be in the IO monad" -- ty -> (True, ty) isUnit = pureType == ConT ''() nArgs = countArgs typeSig -- in sequence [ sigD n typeSigQ, valD (varP cifN) (normalB [| getCifForFunction $(varE n) |]) [], valD (varP ptrN) (normalB [| unsafePerformIO $ lookupSymbol $(stringE name) |]) [], funD n [ clause (map (varP.mkName) arguments) (normalB $ marshallerBody) [] ] ] --- NEW FILE: Exception.hs-boot --- module HOC.Exception where import HOC.Base import Foreign exceptionObjCToHaskell :: Ptr ObjCObject -> IO a exceptionHaskellToObjC :: IO a -> IO (Ptr ObjCObject) --- NEW FILE: Dyld.hs --- module HOC.Dyld( lookupSymbol, lookupSymbol# ) where import GHC.Exts(Ptr(..), Addr#) import Foreign import Foreign.C.String -- Up to GHC 6.4.0, there was a bug where rtldDefault was marshalled -- incorrectly for Mac OS X, so we do it by hand. foreign import ccall "dlsym" c_dlsym :: Ptr () -> CString -> IO (FunPtr a) rtldDefault = nullPtr `plusPtr` (-2) lookupSymbol :: String -> IO (FunPtr a) lookupSymbol# :: Addr# -> IO (FunPtr a) lookupSymbol name = withCString name (c_dlsym rtldDefault) lookupSymbol# name# = c_dlsym rtldDefault (Ptr name#) Index: Invocation.hs =================================================================== RCS file: /cvsroot/hoc/hoc/HOC/HOC/Invocation.hs,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -d -r1.1.1.1 -r1.2 --- Invocation.hs 27 Oct 2003 16:48:09 -0000 1.1.1.1 +++ Invocation.hs 27 Sep 2005 11:55:22 -0000 1.2 @@ -1,13 +1,14 @@ module HOC.Invocation where import Foreign -import Control.Monad ( when ) -import Control.Exception ( bracket ) +import Control.Monad ( when ) import HOC.Base import HOC.Arguments import HOC.FFICallInterface +import {-# SOURCE #-} HOC.Exception + foreign import ccall "Invocation.h callWithExceptions" c_callWithExceptions :: FFICif -> FunPtr a -> Ptr b -> Ptr (Ptr ()) @@ -16,12 +17,12 @@ callWithException cif fun ret args = do exception <- c_callWithExceptions cif fun ret args when (exception /= nullPtr) $ - error "## exception marshalling not yet implemented ###" + exceptionObjCToHaskell exception withMarshalledArgument :: ObjCArgument a b => a -> (Ptr () -> IO c) -> IO c withMarshalledArgument arg act = - withExportedArgument arg (\exported -> withObject exported (act . castPtr)) + withExportedArgument arg (\exported -> with exported (act . castPtr)) callWithoutRetval :: FFICif -> FunPtr a -> Ptr (Ptr ()) @@ -50,7 +51,3 @@ p <- peekElemOff args idx arg <- peek (castPtr p) importArgument arg - -exceptionHaskellToObjC action = - action >> return nullPtr {- ### `catch` return some nsexception -} - \ No newline at end of file |
