{-# LANGUAGE Unsafe #-}
{-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}

module GHC.Event.Internal
    (
    -- * Event back end
      Backend
    , backend
    , delete
    , poll
    , modifyFd
    , modifyFdOnce
    , module GHC.Event.Internal.Types
    -- * Helpers
    , throwErrnoIfMinus1NoRetry

    -- Atomic ptr exchange for WinIO
    , exchangePtr
    ) where

import Foreign.C.Error (eINTR, getErrno, throwErrno)
import System.Posix.Types (Fd)
import GHC.Base
import GHC.Num (Num(..))
import GHC.Event.Internal.Types

import GHC.Ptr (Ptr(..))

-- | Event notification backend.
data Backend = forall a. Backend {
      ()
_beState :: !a

    -- | Poll backend for new events.  The provided callback is called
    -- once per file descriptor with new events.
    , ()
_bePoll :: a                          -- backend state
              -> Maybe Timeout              -- timeout in milliseconds ('Nothing' for non-blocking poll)
              -> (Fd -> Event -> IO ())     -- I/O callback
              -> IO Int

    -- | Register, modify, or unregister interest in the given events
    -- on the given file descriptor.
    , ()
_beModifyFd :: a
                  -> Fd       -- file descriptor
                  -> Event    -- old events to watch for ('mempty' for new)
                  -> Event    -- new events to watch for ('mempty' to delete)
                  -> IO Bool

    -- | Register interest in new events on a given file descriptor, set
    -- to be deactivated after the first event.
    , ()
_beModifyFdOnce :: a
                         -> Fd    -- file descriptor
                         -> Event -- new events to watch
                         -> IO Bool

    , ()
_beDelete :: a -> IO ()
    }

backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
        -> (a -> Fd -> Event -> Event -> IO Bool)
        -> (a -> Fd -> Event -> IO Bool)
        -> (a -> IO ())
        -> a
        -> Backend
backend :: forall a.
(a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
-> (a -> Fd -> Event -> Event -> IO Bool)
-> (a -> Fd -> Event -> IO Bool)
-> (a -> IO ())
-> a
-> Backend
backend a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
bPoll a -> Fd -> Event -> Event -> IO Bool
bModifyFd a -> Fd -> Event -> IO Bool
bModifyFdOnce a -> IO ()
bDelete a
state =
  a
-> (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
-> (a -> Fd -> Event -> Event -> IO Bool)
-> (a -> Fd -> Event -> IO Bool)
-> (a -> IO ())
-> Backend
forall a.
a
-> (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
-> (a -> Fd -> Event -> Event -> IO Bool)
-> (a -> Fd -> Event -> IO Bool)
-> (a -> IO ())
-> Backend
Backend a
state a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
bPoll a -> Fd -> Event -> Event -> IO Bool
bModifyFd a -> Fd -> Event -> IO Bool
bModifyFdOnce a -> IO ()
bDelete
{-# INLINE backend #-}

poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
poll (Backend a
bState a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
bPoll a -> Fd -> Event -> Event -> IO Bool
_ a -> Fd -> Event -> IO Bool
_ a -> IO ()
_) = a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
bPoll a
bState
{-# INLINE poll #-}

-- | Returns 'True' if the modification succeeded.
-- Returns 'False' if this backend does not support
-- event notifications on this type of file.
modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool
modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool
modifyFd (Backend a
bState a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
_ a -> Fd -> Event -> Event -> IO Bool
bModifyFd a -> Fd -> Event -> IO Bool
_ a -> IO ()
_) = a -> Fd -> Event -> Event -> IO Bool
bModifyFd a
bState
{-# INLINE modifyFd #-}

-- | Returns 'True' if the modification succeeded.
-- Returns 'False' if this backend does not support
-- event notifications on this type of file.
modifyFdOnce :: Backend -> Fd -> Event -> IO Bool
modifyFdOnce :: Backend -> Fd -> Event -> IO Bool
modifyFdOnce (Backend a
bState a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
_ a -> Fd -> Event -> Event -> IO Bool
_ a -> Fd -> Event -> IO Bool
bModifyFdOnce a -> IO ()
_) = a -> Fd -> Event -> IO Bool
bModifyFdOnce a
bState
{-# INLINE modifyFdOnce #-}

delete :: Backend -> IO ()
delete :: Backend -> IO ()
delete (Backend a
bState a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
_ a -> Fd -> Event -> Event -> IO Bool
_ a -> Fd -> Event -> IO Bool
_ a -> IO ()
bDelete) = a -> IO ()
bDelete a
bState
{-# INLINE delete #-}

-- | Throw an 'Prelude.IOError' corresponding to the current value of
-- 'getErrno' if the result value of the 'IO' action is -1 and
-- 'getErrno' is not 'eINTR'.  If the result value is -1 and
-- 'getErrno' returns 'eINTR' 0 is returned.  Otherwise the result
-- value is returned.
throwErrnoIfMinus1NoRetry :: (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1NoRetry :: forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1NoRetry String
loc IO a
f = do
    a
res <- IO a
f
    if a
res a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1
        then do
            Errno
err <- IO Errno
getErrno
            if Errno
err Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINTR then a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
0 else String -> IO a
forall a. String -> IO a
throwErrno String
loc
        else a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

{-# INLINE exchangePtr #-}
-- | @exchangePtr pptr x@ swaps the pointer pointed to by @pptr@ with the value
-- @x@, returning the old value.
exchangePtr :: Ptr (Ptr a) -> Ptr a -> IO (Ptr a)
exchangePtr :: forall a. Ptr (Ptr a) -> Ptr a -> IO (Ptr a)
exchangePtr (Ptr Addr#
dst) (Ptr Addr#
val) =
  (State# RealWorld -> (# State# RealWorld, Ptr a #)) -> IO (Ptr a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Ptr a #)) -> IO (Ptr a))
-> (State# RealWorld -> (# State# RealWorld, Ptr a #))
-> IO (Ptr a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
      case (Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #)
forall d. Addr# -> Addr# -> State# d -> (# State# d, Addr# #)
atomicExchangeAddrAddr# Addr#
dst Addr#
val State# RealWorld
s) of
        (# State# RealWorld
s2, Addr#
old_val #) -> (# State# RealWorld
s2, Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr Addr#
old_val #)