(original) (raw)

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

module GHC.Event.Internal (

  [Backend](GHC.Event.Internal.html#Backend)
, [backend](GHC.Event.Internal.html#backend)
, [delete](GHC.Event.Internal.html#delete)
, [poll](GHC.Event.Internal.html#poll)
, [modifyFd](GHC.Event.Internal.html#modifyFd)
, [modifyFdOnce](GHC.Event.Internal.html#modifyFdOnce)

, [Event](GHC.Event.Internal.html#Event)
, [evtRead](GHC.Event.Internal.html#evtRead)
, [evtWrite](GHC.Event.Internal.html#evtWrite)
, [evtClose](GHC.Event.Internal.html#evtClose)
, [eventIs](GHC.Event.Internal.html#eventIs)

, [Lifetime](GHC.Event.Internal.html#Lifetime)(..)
, [EventLifetime](GHC.Event.Internal.html#EventLifetime)
, [eventLifetime](GHC.Event.Internal.html#eventLifetime)
, [elLifetime](GHC.Event.Internal.html#elLifetime)
, [elEvent](GHC.Event.Internal.html#elEvent)

, [Timeout](GHC.Event.Internal.html#Timeout)(..)

, [throwErrnoIfMinus1NoRetry](GHC.Event.Internal.html#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](#local-6989586621679340773) "evtRead", evtWrite [so](#local-6989586621679340773) "evtWrite", evtClose [so](#local-6989586621679340773) "evtClose"]) ++ "]" where ev [so](#local-6989586621679340773) disp | e [eventIs](GHC.Event.Internal.html#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](GHC.Event.Internal.html#MultiShot) 
          deriving ( [Show](GHC.Show.html#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 #-} | Forever deriving Show

data Backend = forall a. Backend { _beState ::

, [_bePoll](GHC.Event.Internal.html#%5FbePoll) :: [a](#local-6989586621679340769)                          
          -> [Maybe](GHC.Maybe.html#Maybe) [Timeout](GHC.Event.Internal.html#Timeout)              
          -> ([Fd](System.Posix.Types.html#Fd) -> [Event](GHC.Event.Internal.html#Event) -> IO ())     
          -> IO Int


, [_beModifyFd](GHC.Event.Internal.html#%5FbeModifyFd) :: [a](#local-6989586621679340769)
              -> [Fd](System.Posix.Types.html#Fd)       
              -> [Event](GHC.Event.Internal.html#Event)    
              -> [Event](GHC.Event.Internal.html#Event)    
              -> IO Bool


, [_beModifyFdOnce](GHC.Event.Internal.html#%5FbeModifyFdOnce) :: [a](#local-6989586621679340769)
                     -> [Fd](System.Posix.Types.html#Fd)    
                     -> [Event](GHC.Event.Internal.html#Event) 
                     -> IO Bool

, [_beDelete](GHC.Event.Internal.html#%5FbeDelete) :: [a](#local-6989586621679340769) -> 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