1 {-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}
3 module GHC.Event.Internal
20 , throwErrnoIfMinus1NoRetry
23 import Data.Bits ((.|.), (.&.))
24 import Data.List (foldl', intercalate)
25 import Data.Monoid (Monoid(..))
26 import Foreign.C.Error (eINTR, getErrno, throwErrno)
27 import System.Posix.Types (Fd)
29 import GHC.Num (Num(..))
30 import GHC.Show (Show(..))
31 import GHC.List (filter, null)
34 newtype Event = Event Int
39 {-# INLINE evtNothing #-}
41 -- | Data is available to be read.
44 {-# INLINE evtRead #-}
46 -- | The file descriptor is ready to accept a write.
49 {-# INLINE evtWrite #-}
51 -- | Another thread closed the file descriptor.
54 {-# INLINE evtClose #-}
56 eventIs :: Event -> Event -> Bool
57 eventIs (Event a) (Event b) = a .&. b /= 0
59 instance Show Event where
60 show e = '[' : (intercalate "," . filter (not . null) $
61 [evtRead `so` "evtRead",
62 evtWrite `so` "evtWrite",
63 evtClose `so` "evtClose"]) ++ "]"
64 where ev `so` disp | e `eventIs` ev = disp
67 instance Monoid Event where
72 evtCombine :: Event -> Event -> Event
73 evtCombine (Event a) (Event b) = Event (a .|. b)
74 {-# INLINE evtCombine #-}
76 evtConcat :: [Event] -> Event
77 evtConcat = foldl' evtCombine evtNothing
78 {-# INLINE evtConcat #-}
80 -- | A type alias for timeouts, specified in seconds.
81 data Timeout = Timeout {-# UNPACK #-} !Double
85 -- | Event notification backend.
86 data Backend = forall a. Backend {
89 -- | Poll backend for new events. The provided callback is called
90 -- once per file descriptor with new events.
91 , _bePoll :: a -- backend state
92 -> Timeout -- timeout in milliseconds
93 -> (Fd -> Event -> IO ()) -- I/O callback
96 -- | Register, modify, or unregister interest in the given events
97 -- on the given file descriptor.
99 -> Fd -- file descriptor
100 -> Event -- old events to watch for ('mempty' for new)
101 -> Event -- new events to watch for ('mempty' to delete)
104 , _beDelete :: a -> IO ()
107 backend :: (a -> Timeout -> (Fd -> Event -> IO ()) -> IO ())
108 -> (a -> Fd -> Event -> Event -> IO ())
112 backend bPoll bModifyFd bDelete state = Backend state bPoll bModifyFd bDelete
113 {-# INLINE backend #-}
115 poll :: Backend -> Timeout -> (Fd -> Event -> IO ()) -> IO ()
116 poll (Backend bState bPoll _ _) = bPoll bState
119 modifyFd :: Backend -> Fd -> Event -> Event -> IO ()
120 modifyFd (Backend bState _ bModifyFd _) = bModifyFd bState
121 {-# INLINE modifyFd #-}
123 delete :: Backend -> IO ()
124 delete (Backend bState _ _ bDelete) = bDelete bState
125 {-# INLINE delete #-}
127 -- | Throw an 'IOError' corresponding to the current value of
128 -- 'getErrno' if the result value of the 'IO' action is -1 and
129 -- 'getErrno' is not 'eINTR'. If the result value is -1 and
130 -- 'getErrno' returns 'eINTR' 0 is returned. Otherwise the result
131 -- value is returned.
132 throwErrnoIfMinus1NoRetry :: Num a => String -> IO a -> IO a
133 throwErrnoIfMinus1NoRetry loc f = do
138 if err == eINTR then return 0 else throwErrno loc