1 {-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}
3 module System.Event.Internal
19 , throwErrnoIfMinus1NoRetry
22 import Data.Bits ((.|.), (.&.))
23 import Data.List (foldl', intercalate)
24 import Data.Monoid (Monoid(..))
25 import Foreign.C.Error (eINTR, getErrno, throwErrno)
26 import System.Posix.Types (Fd)
28 import GHC.Num (Num(..))
29 import GHC.Show (Show(..))
30 import GHC.List (filter, null)
33 newtype Event = Event Int
38 {-# INLINE evtNothing #-}
42 {-# INLINE evtRead #-}
46 {-# INLINE evtWrite #-}
48 eventIs :: Event -> Event -> Bool
49 eventIs (Event a) (Event b) = a .&. b /= 0
51 instance Show Event where
52 show e = '[' : (intercalate "," . filter (not . null) $
53 [evtRead `so` "evtRead", evtWrite `so` "evtWrite"]) ++ "]"
54 where ev `so` disp | e `eventIs` ev = disp
57 instance Monoid Event where
62 evtCombine :: Event -> Event -> Event
63 evtCombine (Event a) (Event b) = Event (a .|. b)
64 {-# INLINE evtCombine #-}
66 evtConcat :: [Event] -> Event
67 evtConcat = foldl' evtCombine evtNothing
68 {-# INLINE evtConcat #-}
70 -- | A type alias for timeouts, specified in seconds.
71 data Timeout = Timeout {-# UNPACK #-} !Double
75 -- | Event notification backend.
76 data Backend = forall a. Backend {
79 -- | Poll backend for new events. The provided callback is called
80 -- once per file descriptor with new events.
81 , _bePoll :: a -- backend state
82 -> Timeout -- timeout in milliseconds
83 -> (Fd -> Event -> IO ()) -- I/O callback
86 -- | Register, modify, or unregister interest in the given events
87 -- on the given file descriptor.
89 -> Fd -- file descriptor
90 -> Event -- old events to watch for ('mempty' for new)
91 -> Event -- new events to watch for ('mempty' to delete)
94 , _beDelete :: a -> IO ()
97 backend :: (a -> Timeout -> (Fd -> Event -> IO ()) -> IO ())
98 -> (a -> Fd -> Event -> Event -> IO ())
102 backend bPoll bModifyFd bDelete state = Backend state bPoll bModifyFd bDelete
103 {-# INLINE backend #-}
105 poll :: Backend -> Timeout -> (Fd -> Event -> IO ()) -> IO ()
106 poll (Backend bState bPoll _ _) = bPoll bState
109 modifyFd :: Backend -> Fd -> Event -> Event -> IO ()
110 modifyFd (Backend bState _ bModifyFd _) = bModifyFd bState
111 {-# INLINE modifyFd #-}
113 delete :: Backend -> IO ()
114 delete (Backend bState _ _ bDelete) = bDelete bState
115 {-# INLINE delete #-}
117 -- | Throw an 'IOError' corresponding to the current value of
118 -- 'getErrno' if the result value of the 'IO' action is -1 and
119 -- 'getErrno' is not 'eINTR'. If the result value is -1 and
120 -- 'getErrno' returns 'eINTR' 0 is returned. Otherwise the result
121 -- value is returned.
122 throwErrnoIfMinus1NoRetry :: Num a => String -> IO a -> IO a
123 throwErrnoIfMinus1NoRetry loc f = do
128 if err == eINTR then return 0 else throwErrno loc