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