-- |
-- Copyright: (C) 2015 Tweag I/O Limited.
--
-- Helper module for writing event loops that mesh with R events.
--
-- Events in R are dispatched from a number of file descriptors. The R runtime
-- maintains a list of "input handlers", essentially a set of file descriptors
-- together with callbacks for each one, invoked whenever the file descriptor
-- becomes available for reading. This module exports functions for dispatching
-- on both R events and Haskell events simultaneously, using "GHC.Event", which
-- is based on epoll/kqueue/poll under the hood for efficient and scalable event
-- dispatching.
--
-- Event dispatching and processing is in particular necessary for R's GUI to be
-- responsive. For a consistent user experience, you should arrange for all GUI
-- related events to be dispatched from a single thread, ideally the program's
-- main thread. In fact on some platforms, most notably OS X (darwin), you
-- /must/ use the main thread.
--
-- Event loops can be constructed in one of two ways:
--
--   1. 'eventLoopPoll', which uses GHC's @poll(2)@ (and related syscalls) based
--   efficient and scalable mechanisms for event dispatch;
--
--   2. 'eventLoopSelect', which uses R's @select(2)@ based mechasism.
--
-- __NOTE:__ in GHC 7.8 and 7.10, 'eventLoopPoll' is currently unusable, due to
-- a number of functions from the event API not being exported like they were
-- previously.

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}

module Language.R.Event
  ( forIH
  , forIH_
  , registerREvents
  , eventLoopPoll
  , eventLoopSelect
  , refresh
  ) where

import Control.Applicative
import Control.Monad (forever)
import Control.Monad.R.Class
import Data.Maybe (catMaybes)
import qualified Foreign.R.EventLoop as R
import qualified GHC.Event as Event
import Language.R.Globals (inputHandlers)
import Foreign (FunPtr, Ptr, nullPtr, peek)
import Prelude -- Silence AMP warning.

-- | Iterate over each input handler in a chain.
forIH :: Ptr R.InputHandler -> (R.InputHandler -> IO a) -> IO [a]
forIH :: Ptr InputHandler -> (InputHandler -> IO a) -> IO [a]
forIH ihptr :: Ptr InputHandler
ihptr f :: InputHandler -> IO a
f
  | Ptr InputHandler
ihptr Ptr InputHandler -> Ptr InputHandler -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr InputHandler
forall a. Ptr a
nullPtr = [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Bool
otherwise = do
    InputHandler
ih <- Ptr InputHandler -> IO InputHandler
forall a. Storable a => Ptr a -> IO a
peek Ptr InputHandler
ihptr
    (:) (a -> [a] -> [a]) -> IO a -> IO ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputHandler -> IO a
f InputHandler
ih IO ([a] -> [a]) -> IO [a] -> IO [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr InputHandler -> (InputHandler -> IO a) -> IO [a]
forall a. Ptr InputHandler -> (InputHandler -> IO a) -> IO [a]
forIH (InputHandler -> Ptr InputHandler
R.inputHandlerNext InputHandler
ih) InputHandler -> IO a
f

-- | Variant of 'forIH' that throws away the result.
forIH_ :: Ptr R.InputHandler -> (R.InputHandler -> IO ()) -> IO ()
forIH_ :: Ptr InputHandler -> (InputHandler -> IO ()) -> IO ()
forIH_ ihptr :: Ptr InputHandler
ihptr f :: InputHandler -> IO ()
f
  | Ptr InputHandler
ihptr Ptr InputHandler -> Ptr InputHandler -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr InputHandler
forall a. Ptr a
nullPtr = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = do
    InputHandler
ih <- Ptr InputHandler -> IO InputHandler
forall a. Storable a => Ptr a -> IO a
peek Ptr InputHandler
ihptr
    InputHandler -> IO ()
f InputHandler
ih
    Ptr InputHandler -> (InputHandler -> IO ()) -> IO ()
forIH_ (InputHandler -> Ptr InputHandler
R.inputHandlerNext InputHandler
ih) InputHandler -> IO ()
f

foreign import ccall "dynamic" invokeIO :: FunPtr (IO ()) -> IO ()
foreign import ccall "dynamic" invokeCallback :: FunPtr (Ptr () -> IO ()) -> Ptr () -> IO ()

-- | Register all R input handlers with the given event manager. Set an alarm to
-- process polled events if @R_wait_usec@ is non-zero. Returns keys useful for
-- unregistering input handlers.
registerREvents
  :: MonadR m
  => Event.EventManager
  -> m ([Event.FdKey], Maybe Event.TimeoutKey)
registerREvents :: EventManager -> m ([FdKey], Maybe TimeoutKey)
registerREvents emgr :: EventManager
emgr = IO ([FdKey], Maybe TimeoutKey) -> m ([FdKey], Maybe TimeoutKey)
forall (m :: * -> *) a. MonadR m => IO a -> m a
io (IO ([FdKey], Maybe TimeoutKey) -> m ([FdKey], Maybe TimeoutKey))
-> IO ([FdKey], Maybe TimeoutKey) -> m ([FdKey], Maybe TimeoutKey)
forall a b. (a -> b) -> a -> b
$ do
    TimerManager
tmgr <- IO TimerManager
Event.getSystemTimerManager
    [Maybe FdKey]
fdkeys <- Ptr InputHandler
-> (InputHandler -> IO (Maybe FdKey)) -> IO [Maybe FdKey]
forall a. Ptr InputHandler -> (InputHandler -> IO a) -> IO [a]
forIH Ptr InputHandler
inputHandlers ((InputHandler -> IO (Maybe FdKey)) -> IO [Maybe FdKey])
-> (InputHandler -> IO (Maybe FdKey)) -> IO [Maybe FdKey]
forall a b. (a -> b) -> a -> b
$ \R.InputHandler{..} -> do
      let action :: p -> p -> IO ()
action _ _ = FunPtr (Ptr () -> IO ()) -> Ptr () -> IO ()
invokeCallback FunPtr (Ptr () -> IO ())
inputHandlerCallback Ptr ()
inputHandlerUserData
      case 0 CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
inputHandlerActive of
        True ->
#if MIN_VERSION_base(4,8,1)
          FdKey -> Maybe FdKey
forall a. a -> Maybe a
Just (FdKey -> Maybe FdKey) -> IO FdKey -> IO (Maybe FdKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventManager -> IOCallback -> Fd -> Event -> Lifetime -> IO FdKey
Event.registerFd EventManager
emgr IOCallback
forall p p. p -> p -> IO ()
action Fd
inputHandlerFD Event
Event.evtRead Lifetime
Event.MultiShot
#elif MIN_VERSION_base(4,8,0)
          fail "registerREvents not implementable in GHC 7.10.1. Use 7.10.2."
#else
          Just <$> Event.registerFd emgr action inputHandlerFD Event.evtRead
#endif
        False -> Maybe FdKey -> IO (Maybe FdKey)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FdKey
forall a. Maybe a
Nothing
    CInt
usecs <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
R.pollingPeriod
    CInt
gusecs <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
R.graphicsPollingPeriod
    let eusecs :: CInt
eusecs
          | CInt
usecs CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& CInt
gusecs CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = 10000
          | CInt
usecs CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| CInt
gusecs CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = CInt -> CInt -> CInt
forall a. Ord a => a -> a -> a
max CInt
usecs CInt
gusecs
          | Bool
otherwise = CInt -> CInt -> CInt
forall a. Ord a => a -> a -> a
min CInt
usecs CInt
gusecs
    Maybe TimeoutKey
mbtkey <- case 0 CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
eusecs of
      True -> do
        let action :: IO ()
action = do
              Ptr (FunPtr (IO ())) -> IO (FunPtr (IO ()))
forall a. Storable a => Ptr a -> IO a
peek Ptr (FunPtr (IO ()))
R.polledEvents IO (FunPtr (IO ())) -> (FunPtr (IO ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FunPtr (IO ()) -> IO ()
invokeIO
              Ptr (FunPtr (IO ())) -> IO (FunPtr (IO ()))
forall a. Storable a => Ptr a -> IO a
peek Ptr (FunPtr (IO ()))
R.graphicsPolledEvents IO (FunPtr (IO ())) -> (FunPtr (IO ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FunPtr (IO ()) -> IO ()
invokeIO
        TimeoutKey -> Maybe TimeoutKey
forall a. a -> Maybe a
Just (TimeoutKey -> Maybe TimeoutKey)
-> IO TimeoutKey -> IO (Maybe TimeoutKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TimerManager -> Int -> IO () -> IO TimeoutKey
Event.registerTimeout TimerManager
tmgr (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
usecs) IO ()
action
      False -> Maybe TimeoutKey -> IO (Maybe TimeoutKey)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TimeoutKey
forall a. Maybe a
Nothing
    ([FdKey], Maybe TimeoutKey) -> IO ([FdKey], Maybe TimeoutKey)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe FdKey] -> [FdKey]
forall a. [Maybe a] -> [a]
catMaybes [Maybe FdKey]
fdkeys, Maybe TimeoutKey
mbtkey)

-- | Process events in a loop. Uses a new GHC event manager under the hood. This
-- function should be called from the main thread. It never returns.
--
-- Currently unimplemented.
eventLoopPoll :: MonadR m => m ()
eventLoopPoll :: m ()
eventLoopPoll = [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error "Unimplemented."

-- | Process events in a loop. Uses R's @select()@ mechanism under the hood.
-- This function should be called from the main thread. It never returns.
eventLoopSelect :: MonadR m => m ()
eventLoopSelect :: m ()
eventLoopSelect =
    IO () -> m ()
forall (m :: * -> *) a. MonadR m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      CInt
usecs <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
R.pollingPeriod
      CInt
gusecs <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
R.graphicsPollingPeriod
      let eusecs :: CInt
eusecs
            | CInt
usecs CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& CInt
gusecs CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = 10000
            | CInt
usecs CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| CInt
gusecs CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = CInt -> CInt -> CInt
forall a. Ord a => a -> a -> a
max CInt
usecs CInt
gusecs
            | Bool
otherwise = CInt -> CInt -> CInt
forall a. Ord a => a -> a -> a
min CInt
usecs CInt
gusecs
      CInt -> CInt -> IO (Ptr FdSet)
R.checkActivity CInt
eusecs 1 IO (Ptr FdSet) -> (Ptr FdSet -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        Ptr InputHandler -> Ptr FdSet -> IO ()
R.runHandlers Ptr InputHandler
inputHandlers

-- | Manually trigger processing all pending events. Useful when at an
-- interactive prompt and no event loop is running.
refresh :: MonadR m => m ()
refresh :: m ()
refresh = IO () -> m ()
forall (m :: * -> *) a. MonadR m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> IO (Ptr FdSet)
R.checkActivity 0 1 IO (Ptr FdSet) -> (Ptr FdSet -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr InputHandler -> Ptr FdSet -> IO ()
R.runHandlers Ptr InputHandler
inputHandlers