-- |
-- 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 :: forall a. Ptr InputHandler -> (InputHandler -> IO a) -> IO [a]
forIH Ptr InputHandler
ihptr InputHandler -> IO a
f
  | Ptr InputHandler
ihptr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr = forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Bool
otherwise = do
    InputHandler
ih <- forall a. Storable a => Ptr a -> IO a
peek Ptr InputHandler
ihptr
    (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputHandler -> IO a
f InputHandler
ih forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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_ Ptr InputHandler
ihptr InputHandler -> IO ()
f
  | Ptr InputHandler
ihptr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = do
    InputHandler
ih <- 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 :: forall (m :: * -> *).
MonadR m =>
EventManager -> m ([FdKey], Maybe TimeoutKey)
registerREvents EventManager
emgr = forall (m :: * -> *) a. MonadR m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ do
    TimerManager
tmgr <- IO TimerManager
Event.getSystemTimerManager
    [Maybe FdKey]
fdkeys <- forall a. Ptr InputHandler -> (InputHandler -> IO a) -> IO [a]
forIH Ptr InputHandler
inputHandlers forall a b. (a -> b) -> a -> b
$ \R.InputHandler{Ptr ()
Ptr InputHandler
FunPtr (Ptr () -> IO ())
Fd
CInt
inputHandlerUserData :: InputHandler -> Ptr ()
inputHandlerFD :: InputHandler -> Fd
inputHandlerActive :: InputHandler -> CInt
inputHandlerActivity :: InputHandler -> CInt
inputHandlerCallback :: InputHandler -> FunPtr (Ptr () -> IO ())
inputHandlerNext :: Ptr InputHandler
inputHandlerUserData :: Ptr ()
inputHandlerFD :: Fd
inputHandlerActive :: CInt
inputHandlerActivity :: CInt
inputHandlerCallback :: FunPtr (Ptr () -> IO ())
inputHandlerNext :: InputHandler -> Ptr InputHandler
..} -> do
      let action :: p -> p -> IO ()
action p
_ p
_ = FunPtr (Ptr () -> IO ()) -> Ptr () -> IO ()
invokeCallback FunPtr (Ptr () -> IO ())
inputHandlerCallback Ptr ()
inputHandlerUserData
      case CInt
0 forall a. Ord a => a -> a -> Bool
< CInt
inputHandlerActive of
        Bool
True ->
#if MIN_VERSION_base(4,8,1)
          forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventManager -> IOCallback -> Fd -> Event -> Lifetime -> IO FdKey
Event.registerFd EventManager
emgr 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
        Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    CInt
usecs <- forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
R.pollingPeriod
    CInt
gusecs <- forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
R.graphicsPollingPeriod
    let eusecs :: CInt
eusecs
          | CInt
usecs forall a. Eq a => a -> a -> Bool
== CInt
0 Bool -> Bool -> Bool
&& CInt
gusecs forall a. Eq a => a -> a -> Bool
== CInt
0 = CInt
10000
          | CInt
usecs forall a. Eq a => a -> a -> Bool
== CInt
0 Bool -> Bool -> Bool
|| CInt
gusecs forall a. Eq a => a -> a -> Bool
== CInt
0 = forall a. Ord a => a -> a -> a
max CInt
usecs CInt
gusecs
          | Bool
otherwise = forall a. Ord a => a -> a -> a
min CInt
usecs CInt
gusecs
    Maybe TimeoutKey
mbtkey <- case CInt
0 forall a. Ord a => a -> a -> Bool
< CInt
eusecs of
      Bool
True -> do
        let action :: IO ()
action = do
              forall a. Storable a => Ptr a -> IO a
peek Ptr (FunPtr (IO ()))
R.polledEvents forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FunPtr (IO ()) -> IO ()
invokeIO
              forall a. Storable a => Ptr a -> IO a
peek Ptr (FunPtr (IO ()))
R.graphicsPolledEvents forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FunPtr (IO ()) -> IO ()
invokeIO
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TimerManager -> Int -> IO () -> IO TimeoutKey
Event.registerTimeout TimerManager
tmgr (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
usecs) IO ()
action
      Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: forall (m :: * -> *). MonadR m => m ()
eventLoopPoll = forall a. HasCallStack => [Char] -> a
error [Char]
"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 :: forall (m :: * -> *). MonadR m => m ()
eventLoopSelect =
    forall (m :: * -> *) a. MonadR m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
      CInt
usecs <- forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
R.pollingPeriod
      CInt
gusecs <- forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
R.graphicsPollingPeriod
      let eusecs :: CInt
eusecs
            | CInt
usecs forall a. Eq a => a -> a -> Bool
== CInt
0 Bool -> Bool -> Bool
&& CInt
gusecs forall a. Eq a => a -> a -> Bool
== CInt
0 = CInt
10000
            | CInt
usecs forall a. Eq a => a -> a -> Bool
== CInt
0 Bool -> Bool -> Bool
|| CInt
gusecs forall a. Eq a => a -> a -> Bool
== CInt
0 = forall a. Ord a => a -> a -> a
max CInt
usecs CInt
gusecs
            | Bool
otherwise = forall a. Ord a => a -> a -> a
min CInt
usecs CInt
gusecs
      CInt -> CInt -> IO (Ptr FdSet)
R.checkActivity CInt
eusecs CInt
1 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 :: forall (m :: * -> *). MonadR m => m ()
refresh = forall (m :: * -> *) a. MonadR m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> IO (Ptr FdSet)
R.checkActivity CInt
0 CInt
1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr InputHandler -> Ptr FdSet -> IO ()
R.runHandlers Ptr InputHandler
inputHandlers