Extra.hs

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]