{-# LANGUAGE Unsafe #-}
{-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}
module GHC.Event.Internal
(
Backend
, backend
, delete
, poll
, modifyFd
, modifyFdOnce
, Event
, evtRead
, evtWrite
, evtClose
, eventIs
, Lifetime(..)
, EventLifetime
, eventLifetime
, elLifetime
, elEvent
, Timeout(..)
, 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)
newtype Event = Event Int
deriving (Eq)
evtNothing :: Event
evtNothing = Event 0
{-# INLINE evtNothing #-}
evtRead :: Event
evtRead = Event 1
{-# INLINE evtRead #-}
evtWrite :: Event
evtWrite = Event 2
{-# INLINE evtWrite #-}
evtClose :: Event
evtClose = Event 4
{-# INLINE evtClose #-}
eventIs :: Event -> Event -> Bool
eventIs (Event a) (Event b) = a .&. b /= 0
instance Show Event where
show e = '[' : (intercalate "," . filter (not . null) $
[evtRead `so` "evtRead",
evtWrite `so` "evtWrite",
evtClose `so` "evtClose"]) ++ "]"
where ev `so` disp | e `eventIs` ev = disp
| otherwise = ""
instance Semigroup Event where
(<>) = evtCombine
stimes = stimesMonoid
instance Monoid Event where
mempty = evtNothing
mconcat = evtConcat
evtCombine :: Event -> Event -> Event
evtCombine (Event a) (Event b) = Event (a .|. b)
{-# INLINE evtCombine #-}
evtConcat :: [Event] -> Event
evtConcat = foldl' evtCombine evtNothing
{-# INLINE evtConcat #-}
data Lifetime = OneShot
| MultiShot
deriving (Show, Eq)
elSupremum :: Lifetime -> Lifetime -> Lifetime
elSupremum OneShot OneShot = OneShot
elSupremum _ _ = MultiShot
{-# INLINE elSupremum #-}
instance Semigroup Lifetime where
(<>) = elSupremum
stimes = stimesMonoid
instance Monoid Lifetime where
mempty = OneShot
newtype EventLifetime = EL Int
deriving (Show, Eq)
instance Semigroup EventLifetime where
EL a <> EL b = EL (a .|. b)
instance Monoid EventLifetime where
mempty = EL 0
eventLifetime :: Event -> Lifetime -> EventLifetime
eventLifetime (Event e) l = EL (e .|. lifetimeBit l)
where
lifetimeBit OneShot = 0
lifetimeBit MultiShot = 8
{-# INLINE eventLifetime #-}
elLifetime :: EventLifetime -> Lifetime
elLifetime (EL x) = if x .&. 8 == 0 then OneShot else MultiShot
{-# INLINE elLifetime #-}
elEvent :: EventLifetime -> Event
elEvent (EL x) = Event (x .&. 0x7)
{-# INLINE elEvent #-}
data Timeout = Timeout {-# UNPACK #-} !Word64
| Forever
deriving (Show)
data Backend = forall a. Backend {
_beState :: !a
, _bePoll :: a
-> Maybe Timeout
-> (Fd -> Event -> IO ())
-> IO Int
, _beModifyFd :: a
-> Fd
-> Event
-> Event
-> IO Bool
, _beModifyFdOnce :: a
-> Fd
-> Event
-> 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 bPoll bModifyFd bModifyFdOnce bDelete state =
Backend state bPoll bModifyFd bModifyFdOnce bDelete
{-# INLINE backend #-}
poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
poll (Backend bState bPoll _ _ _) = bPoll bState
{-# INLINE poll #-}
modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool
modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState
{-# INLINE modifyFd #-}
modifyFdOnce :: Backend -> Fd -> Event -> IO Bool
modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState
{-# INLINE modifyFdOnce #-}
delete :: Backend -> IO ()
delete (Backend bState _ _ _ bDelete) = bDelete bState
{-# INLINE delete #-}
throwErrnoIfMinus1NoRetry :: (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1NoRetry loc f = do
res <- f
if res == -1
then do
err <- getErrno
if err == eINTR then return 0 else throwErrno loc
else return res