{-# 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
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
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 ()
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)
eventLoopPoll :: MonadR m => m ()
eventLoopPoll :: forall (m :: * -> *). MonadR m => m ()
eventLoopPoll = forall a. HasCallStack => [Char] -> a
error [Char]
"Unimplemented."
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
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