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

module GHC.Event.Internal
    (
    -- * Event back end
      Backend
    , backend
    , delete
    , poll
    , modifyFd
    , modifyFdOnce
    -- * Event type
    , Event
    , evtRead
    , evtWrite
    , evtClose
    , eventIs
    -- * Lifetimes
    , Lifetime(..)
    , EventLifetime
    , eventLifetime
    , elLifetime
    , elEvent
    -- * Timeout type
    , Timeout(..)
    -- * Helpers
    , throwErrnoIfMinus1NoRetry
    ) where

import Data.Bits ((.|.), (.&.))
import Data.OldList (foldl', filter, intercalate, null)
import Foreign.C.Error (eINTR, getErrno, throwErrno)
import System.Posix.Types (Fd)
import GHC.Base
import GHC.Word (Word64)
import GHC.Num (Num(..))
import GHC.Show (Show(..))
import Data.Semigroup.Internal (stimesMonoid)

-- | An I\/O event.
newtype Event = Event Int
    deriving Eq -- ^ @since 4.4.0.0

evtNothing :: Event
evtNothing :: Event
evtNothing = Int -> Event
Event Int
0
{-# INLINE evtNothing #-}

-- | Data is available to be read.
evtRead :: Event
evtRead :: Event
evtRead = Int -> Event
Event Int
1
{-# INLINE evtRead #-}

-- | The file descriptor is ready to accept a write.
evtWrite :: Event
evtWrite :: Event
evtWrite = Int -> Event
Event Int
2
{-# INLINE evtWrite #-}

-- | Another thread closed the file descriptor.
evtClose :: Event
evtClose :: Event
evtClose = Int -> Event
Event Int
4
{-# INLINE evtClose #-}

eventIs :: Event -> Event -> Bool
eventIs :: Event -> Event -> Bool
eventIs (Event Int
a) (Event Int
b) = Int
a Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0

-- | @since 4.4.0.0
instance Show Event where
    show :: Event -> String
show Event
e = Char
'[' Char -> ShowS
forall a. a -> [a] -> [a]
: (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
null) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                    [Event
evtRead Event -> ShowS
`so` String
"evtRead",
                     Event
evtWrite Event -> ShowS
`so` String
"evtWrite",
                     Event
evtClose Event -> ShowS
`so` String
"evtClose"]) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
        where Event
ev so :: Event -> ShowS
`so` String
disp | Event
e Event -> Event -> Bool
`eventIs` Event
ev = String
disp
                           | Bool
otherwise      = String
""

-- | @since 4.10.0.0
instance Semigroup Event where
    <> :: Event -> Event -> Event
(<>)    = Event -> Event -> Event
evtCombine
    stimes :: b -> Event -> Event
stimes  = b -> Event -> Event
forall b a. (Integral b, Monoid a) => b -> a -> a
stimesMonoid

-- | @since 4.4.0.0
instance Monoid Event where
    mempty :: Event
mempty  = Event
evtNothing
    mconcat :: [Event] -> Event
mconcat = [Event] -> Event
evtConcat

evtCombine :: Event -> Event -> Event
evtCombine :: Event -> Event -> Event
evtCombine (Event Int
a) (Event Int
b) = Int -> Event
Event (Int
a Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
b)
{-# INLINE evtCombine #-}

evtConcat :: [Event] -> Event
evtConcat :: [Event] -> Event
evtConcat = (Event -> Event -> Event) -> Event -> [Event] -> Event
forall a b. (b -> a -> b) -> b -> [a] -> b
foldl' Event -> Event -> Event
evtCombine Event
evtNothing
{-# INLINE evtConcat #-}

-- | The lifetime of an event registration.
--
-- @since 4.8.1.0
data Lifetime = OneShot   -- ^ the registration will be active for only one
                          -- event
              | MultiShot -- ^ the registration will trigger multiple times
              deriving ( Show -- ^ @since 4.8.1.0
                       , Eq   -- ^ @since 4.8.1.0
                       )

-- | The longer of two lifetimes.
elSupremum :: Lifetime -> Lifetime -> Lifetime
elSupremum :: Lifetime -> Lifetime -> Lifetime
elSupremum Lifetime
OneShot Lifetime
OneShot = Lifetime
OneShot
elSupremum Lifetime
_       Lifetime
_       = Lifetime
MultiShot
{-# INLINE elSupremum #-}

-- | @since 4.10.0.0
instance Semigroup Lifetime where
    <> :: Lifetime -> Lifetime -> Lifetime
(<>) = Lifetime -> Lifetime -> Lifetime
elSupremum
    stimes :: b -> Lifetime -> Lifetime
stimes = b -> Lifetime -> Lifetime
forall b a. (Integral b, Monoid a) => b -> a -> a
stimesMonoid

-- | @mappend@ takes the longer of two lifetimes.
--
-- @since 4.8.0.0
instance Monoid Lifetime where
    mempty :: Lifetime
mempty = Lifetime
OneShot

-- | A pair of an event and lifetime
--
-- Here we encode the event in the bottom three bits and the lifetime
-- in the fourth bit.
newtype EventLifetime = EL Int
                      deriving ( Show -- ^ @since 4.8.0.0
                               , Eq   -- ^ @since 4.8.0.0
                               )

-- | @since 4.11.0.0
instance Semigroup EventLifetime where
    EL Int
a <> :: EventLifetime -> EventLifetime -> EventLifetime
<> EL Int
b = Int -> EventLifetime
EL (Int
a Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
b)

-- | @since 4.8.0.0
instance Monoid EventLifetime where
    mempty :: EventLifetime
mempty = Int -> EventLifetime
EL Int
0

eventLifetime :: Event -> Lifetime -> EventLifetime
eventLifetime :: Event -> Lifetime -> EventLifetime
eventLifetime (Event Int
e) Lifetime
l = Int -> EventLifetime
EL (Int
e Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Lifetime -> Int
forall p. Num p => Lifetime -> p
lifetimeBit Lifetime
l)
  where
    lifetimeBit :: Lifetime -> p
lifetimeBit Lifetime
OneShot   = p
0
    lifetimeBit Lifetime
MultiShot = p
8
{-# INLINE eventLifetime #-}

elLifetime :: EventLifetime -> Lifetime
elLifetime :: EventLifetime -> Lifetime
elLifetime (EL Int
x) = if Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Lifetime
OneShot else Lifetime
MultiShot
{-# INLINE elLifetime #-}

elEvent :: EventLifetime -> Event
elEvent :: EventLifetime -> Event
elEvent (EL Int
x) = Int -> Event
Event (Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x7)
{-# INLINE elEvent #-}

-- | A type alias for timeouts, specified in nanoseconds.
data Timeout = Timeout {-# UNPACK #-} !Word64
             | Forever
               deriving Show -- ^ @since 4.4.0.0

-- | 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 :: (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 :: 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 (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 (m :: * -> *) a. Monad m => a -> m a
return a
res