packages feed

luka 2012.7.7.1 → 2012.8.29

raw patch · 5 files changed

+215/−11 lines, 5 filesdep +bytestring

Dependencies added: bytestring

Files

luka.cabal view
@@ -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
src/Language/ObjectiveC/Luka.hs view
@@ -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+
src/Language/ObjectiveC/Luka/API.hs view
@@ -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++
+ src/Language/ObjectiveC/Luka/Extra.hs view
@@ -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]
src/Language/ObjectiveC/Luka/RunTime.hs view
@@ -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]