diff --git a/luka.cabal b/luka.cabal --- a/luka.cabal +++ b/luka.cabal @@ -1,5 +1,5 @@ Name: luka -Version: 2012.7.7.1 +Version: 2012.8.29 Build-type: Simple Synopsis: Simple ObjectiveC runtime binding Description: Simple ObjectiveC runtime binding @@ -17,6 +17,7 @@ , Nemesis , src/Main.hs , src/Init.hs + , src/Language/ObjectiveC/Luka/Extra.hs Library @@ -25,6 +26,7 @@ build-depends: base < 99 , air , libffi + , bytestring hs-source-dirs: src exposed-modules: Language.ObjectiveC.Luka.RunTime diff --git a/src/Language/ObjectiveC/Luka.hs b/src/Language/ObjectiveC/Luka.hs --- a/src/Language/ObjectiveC/Luka.hs +++ b/src/Language/ObjectiveC/Luka.hs @@ -3,9 +3,12 @@ module Language.ObjectiveC.Luka ( module Language.ObjectiveC.Luka.API +, module Language.ObjectiveC.Luka.Prelude , module Language.ObjectiveC.Luka.RunTime ) where import Language.ObjectiveC.Luka.API +import Language.ObjectiveC.Luka.Prelude import Language.ObjectiveC.Luka.RunTime + diff --git a/src/Language/ObjectiveC/Luka/API.hs b/src/Language/ObjectiveC/Luka/API.hs --- a/src/Language/ObjectiveC/Luka/API.hs +++ b/src/Language/ObjectiveC/Luka/API.hs @@ -13,28 +13,36 @@ import Language.ObjectiveC.Luka.RunTime import Foreign.LibFFI +import Data.ByteString (ByteString) +yes, no :: BOOL +yes = objc_True +no = objc_False +argYES = argCChar yes +argNO = argCChar no +nil :: ID +nil = nullPtr + get_i :: String -> ID -> IO ID get_i ivar_name obj = do object_getInstanceVariable obj ivar_name >>= object_getIvar obj from_ns_string :: ID -> IO String -from_ns_string = msg "UTF8String" [] retCString >=> peekCString +from_ns_string = msg_string "UTF8String" [] with_pool :: IO a -> IO () with_pool _io = do - pool <- class_named "NSAutoreleasePool" >>= msg "alloc" [] retId >>= msg "init" [] retId + pool <- class_named "NSAutoreleasePool" >>= msg "alloc" [] >>= msg "init" [] _io - pool .msg "release" [] retVoid + void - pool .msg "release" [] + -msg :: String -> [Arg] -> RetType a -> ID -> IO a -msg methodName args ret_type obj = sel_named methodName >>= \sel -> objc_msgSend obj sel args ret_type sel_named :: String -> IO SEL sel_named = sel_getUid @@ -42,8 +50,15 @@ ns_string :: String -> IO ID ns_string x = do - class_named "NSString" >>= msg "stringWithUTF8String:" [argString x] retId + class_named "NSString" >>= msg_obj "stringWithUTF8String:" [argString x] +with_ns_string :: String -> (ID -> IO a) -> IO a +with_ns_string x f = do + _ns_string <- class_named "NSString" >>= msg "alloc" [] >>= msg_obj "initWithUTF8String:" [argString x] + r <- f _ns_string + _ns_string.msg "release" [] + + return r class_named :: String -> IO ID class_named = objc_getClass @@ -53,11 +68,82 @@ ns_msg <- ns_string x ns_log - argPtr ns_msg : args +ns_puts' :: String -> IO () +ns_puts' x = ns_puts x [] + +add_method :: String -> String -> FunPtr a -> String -> IO Bool +add_method class_name sel_name method_implementation method_type_encoding = do + class_pointer <- class_named class_name + sel_pointer <- sel_named sel_name + + class_addMethod class_pointer sel_pointer method_implementation method_type_encoding + + + set_method :: String -> String -> FunPtr a -> IO (FunPtr ()) set_method class_name sel_name method_implementation = do class_pointer <- class_named class_name - cmd <- sel_named sel_name + sel_pointer <- sel_named sel_name - method <- class_getInstanceMethod class_pointer cmd + method <- class_getInstanceMethod class_pointer sel_pointer method_setImplementation method method_implementation + + +msg_type :: RetType a -> String -> [Arg] -> ID -> IO a +msg_type ret_type methodName args obj = sel_named methodName >>= \sel -> objc_msgSend obj sel args ret_type + +type MessageReturn a = String -> [Arg] -> ID -> IO a + +msg :: String -> [ID] -> ID -> IO ID +msg methodName args = msg_obj methodName - args.map argPtr + +msg_obj :: MessageReturn ID +msg_obj = msg_type retId + +msg_void :: MessageReturn () +msg_void = msg_type retVoid + +msg_cint :: MessageReturn CInt +msg_cint = msg_type retCInt + +msg_cuint :: MessageReturn CUInt +msg_cuint = msg_type retCUInt + +msg_clong :: MessageReturn CLong +msg_clong = msg_type retCLong + +msg_culong :: MessageReturn CULong +msg_culong = msg_type retCULong + +msg_cfloat :: MessageReturn CFloat +msg_cfloat = msg_type retCFloat + +msg_cdouble :: MessageReturn CDouble +msg_cdouble = msg_type retCDouble + +msg_csize :: MessageReturn CSize +msg_csize = msg_type retCSize + +msg_ctime :: MessageReturn CTime +msg_ctime = msg_type retCTime + +msg_cchar :: MessageReturn CChar +msg_cchar = msg_type retCChar + +msg_cuchar :: MessageReturn CUChar +msg_cuchar = msg_type retCUChar + +msg_cwchar :: MessageReturn CWchar +msg_cwchar = msg_type retCWchar + +msg_cstring :: MessageReturn CString +msg_cstring = msg_type retCString + +msg_string :: MessageReturn String +msg_string = msg_type retString + +msg_bytestring :: MessageReturn ByteString +msg_bytestring = msg_type retByteString + + diff --git a/src/Language/ObjectiveC/Luka/Extra.hs b/src/Language/ObjectiveC/Luka/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjectiveC/Luka/Extra.hs @@ -0,0 +1,110 @@ +module Language.ObjectiveC.Luka.Extra where + + +import Prelude () +import Air.Env +import Air.Extra +import Control.Monad ((>=>)) + + +import Language.ObjectiveC.Luka.API +import Language.ObjectiveC.Luka.Prelude +import Language.ObjectiveC.Luka.RunTime + +import Foreign.C.Types +import Foreign hiding (void) +import Foreign.LibFFI +import Control.Concurrent.STM.TChan +import Control.Concurrent.STM (atomically) +import Control.Concurrent (forkOS) + +import Data.IORef + + +g_dispatch_main_pool :: TChan (IO ()) +g_dispatch_main_pool = purify - newTChanIO + +g_dispatch_main_method :: IORef (Maybe String) +g_dispatch_main_method = purify - newIORef Nothing + +g_dispatch_main_method_name :: String +g_dispatch_main_method_name = "g_dispatch_main_mailbox" + +g_dispatch_main_method_type_encoding :: String +g_dispatch_main_method_type_encoding = "v" + g_dispatch_main_method_name.length.show + +type Self = ID + +type DispatchMain = Self -> IO () +foreign import ccall "wrapper" mk_DispatchMain :: DispatchMain -> IO (FunPtr DispatchMain) + +m_DispatchMain :: Self -> IO () +m_DispatchMain self = do + -- puts "m_DispatchMain" + + pool_empty <- atomically - isEmptyTChan g_dispatch_main_pool + + if pool_empty + then + return () + else do + io <- atomically - readTChan g_dispatch_main_pool + + io + + m_DispatchMain self + +ns_application_delegate :: IO ID +ns_application_delegate = class_named "NSApplication" >>= msg "sharedApplication" [] >>= msg "delegate" [] + +-- Must be hooked into NSApplicationDelegate, e.g. [NSApplication sharedApplication].delegate +init_dispatch_main :: IO () +init_dispatch_main = do + dispatch_main_method <- readIORef g_dispatch_main_method + + case dispatch_main_method of + Nothing -> do + application_delegate_class <- ns_application_delegate >>= msg "class" [] + + -- ns_puts "delegate class is: %@" [argPtr application_delegate_class] + + sel <- sel_named g_dispatch_main_method_name + + method_implementation <- mk_DispatchMain m_DispatchMain + + -- puts - "Inserting method: " + g_dispatch_main_method_name + " with encoding: " + g_dispatch_main_method_type_encoding + " into NSApp.delegate" + class_addMethod application_delegate_class sel method_implementation g_dispatch_main_method_type_encoding + + writeIORef g_dispatch_main_method - Just g_dispatch_main_method_name + + end + Just _ -> do + puts "g_dispatch_main_method has already been set" + + + + +dispatch_main_after :: Double -> IO () -> IO () +dispatch_main_after after_time io = do + fork_with_pool - do + sleep after_time + -- self.dispatch_main "presentQuestion" + dispatch_main io + + +fork_with_pool :: IO () -> IO () +fork_with_pool io = void - forkOS - with_pool io + + +dispatch_main :: IO () -> IO () +dispatch_main io = do + dispatch_main_method_name <- readIORef g_dispatch_main_method + case dispatch_main_method_name of + Nothing -> do + puts "ERROR: g_dispatch_main_method not initialized, call init_dispatch_main before using dispatch_main" + return () + Just method_name -> do + atomically - writeTChan g_dispatch_main_pool io + + sel_method_name <- sel_named method_name + ns_application_delegate >>= msg_void "performSelectorOnMainThread:withObject:waitUntilDone:" [argPtr sel_method_name, argPtr nil, argNO] diff --git a/src/Language/ObjectiveC/Luka/RunTime.hs b/src/Language/ObjectiveC/Luka/RunTime.hs --- a/src/Language/ObjectiveC/Luka/RunTime.hs +++ b/src/Language/ObjectiveC/Luka/RunTime.hs @@ -44,10 +44,12 @@ data IvarData type Ivar = Ptr IvarData -objc_False :: CChar +type BOOL = CChar + +objc_False :: BOOL objc_False = 0x0 -objc_True :: CChar +objc_True :: BOOL objc_True = 0x1 c2b :: CChar -> Bool @@ -78,6 +80,7 @@ objc_getClass :: String -> IO ID objc_getClass className = callFFI funPtr_objc_getClass retId [argString className] + method_setImplementation :: Ptr a -> FunPtr b -> IO (FunPtr ()) method_setImplementation methodPtr funPtr = callFFI funPtr_method_setImplementation (retFunPtr retVoid) [argPtr methodPtr, argFunPtr funPtr]