base: Export GHC.Event(.Internal).Lifetime
[ghc.git] / libraries / base / GHC / Event / Internal.hs
1 {-# LANGUAGE Unsafe #-}
2 {-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}
3
4 module GHC.Event.Internal
5 (
6 -- * Event back end
7 Backend
8 , backend
9 , delete
10 , poll
11 , modifyFd
12 , modifyFdOnce
13 -- * Event type
14 , Event
15 , evtRead
16 , evtWrite
17 , evtClose
18 , eventIs
19 -- * Lifetimes
20 , Lifetime(..)
21 , EventLifetime
22 , eventLifetime
23 , elLifetime
24 , elEvent
25 -- * Timeout type
26 , Timeout(..)
27 -- * Helpers
28 , throwErrnoIfMinus1NoRetry
29 ) where
30
31 import Data.Bits ((.|.), (.&.))
32 import Data.OldList (foldl', filter, intercalate, null)
33 import Foreign.C.Error (eINTR, getErrno, throwErrno)
34 import System.Posix.Types (Fd)
35 import GHC.Base
36 import GHC.Num (Num(..))
37 import GHC.Show (Show(..))
38
39 -- | An I\/O event.
40 newtype Event = Event Int
41 deriving (Eq)
42
43 evtNothing :: Event
44 evtNothing = Event 0
45 {-# INLINE evtNothing #-}
46
47 -- | Data is available to be read.
48 evtRead :: Event
49 evtRead = Event 1
50 {-# INLINE evtRead #-}
51
52 -- | The file descriptor is ready to accept a write.
53 evtWrite :: Event
54 evtWrite = Event 2
55 {-# INLINE evtWrite #-}
56
57 -- | Another thread closed the file descriptor.
58 evtClose :: Event
59 evtClose = Event 4
60 {-# INLINE evtClose #-}
61
62 eventIs :: Event -> Event -> Bool
63 eventIs (Event a) (Event b) = a .&. b /= 0
64
65 instance Show Event where
66 show e = '[' : (intercalate "," . filter (not . null) $
67 [evtRead `so` "evtRead",
68 evtWrite `so` "evtWrite",
69 evtClose `so` "evtClose"]) ++ "]"
70 where ev `so` disp | e `eventIs` ev = disp
71 | otherwise = ""
72
73 instance Monoid Event where
74 mempty = evtNothing
75 mappend = evtCombine
76 mconcat = evtConcat
77
78 evtCombine :: Event -> Event -> Event
79 evtCombine (Event a) (Event b) = Event (a .|. b)
80 {-# INLINE evtCombine #-}
81
82 evtConcat :: [Event] -> Event
83 evtConcat = foldl' evtCombine evtNothing
84 {-# INLINE evtConcat #-}
85
86 -- | The lifetime of a registration.
87 --
88 -- @since 4.8.1.0
89 data Lifetime = OneShot | MultiShot
90 deriving (Show, Eq)
91
92 -- | The longer of two lifetimes.
93 elSupremum :: Lifetime -> Lifetime -> Lifetime
94 elSupremum OneShot OneShot = OneShot
95 elSupremum _ _ = MultiShot
96 {-# INLINE elSupremum #-}
97
98 instance Monoid Lifetime where
99 mempty = OneShot
100 mappend = elSupremum
101
102 -- | A pair of an event and lifetime
103 --
104 -- Here we encode the event in the bottom three bits and the lifetime
105 -- in the fourth bit.
106 newtype EventLifetime = EL Int
107 deriving (Show, Eq)
108
109 instance Monoid EventLifetime where
110 mempty = EL 0
111 EL a `mappend` EL b = EL (a .|. b)
112
113 eventLifetime :: Event -> Lifetime -> EventLifetime
114 eventLifetime (Event e) l = EL (e .|. lifetimeBit l)
115 where
116 lifetimeBit OneShot = 0
117 lifetimeBit MultiShot = 8
118 {-# INLINE eventLifetime #-}
119
120 elLifetime :: EventLifetime -> Lifetime
121 elLifetime (EL x) = if x .&. 8 == 0 then OneShot else MultiShot
122 {-# INLINE elLifetime #-}
123
124 elEvent :: EventLifetime -> Event
125 elEvent (EL x) = Event (x .&. 0x7)
126 {-# INLINE elEvent #-}
127
128 -- | A type alias for timeouts, specified in seconds.
129 data Timeout = Timeout {-# UNPACK #-} !Double
130 | Forever
131 deriving (Show)
132
133 -- | Event notification backend.
134 data Backend = forall a. Backend {
135 _beState :: !a
136
137 -- | Poll backend for new events. The provided callback is called
138 -- once per file descriptor with new events.
139 , _bePoll :: a -- backend state
140 -> Maybe Timeout -- timeout in milliseconds ('Nothing' for non-blocking poll)
141 -> (Fd -> Event -> IO ()) -- I/O callback
142 -> IO Int
143
144 -- | Register, modify, or unregister interest in the given events
145 -- on the given file descriptor.
146 , _beModifyFd :: a
147 -> Fd -- file descriptor
148 -> Event -- old events to watch for ('mempty' for new)
149 -> Event -- new events to watch for ('mempty' to delete)
150 -> IO Bool
151
152 -- | Register interest in new events on a given file descriptor, set
153 -- to be deactivated after the first event.
154 , _beModifyFdOnce :: a
155 -> Fd -- file descriptor
156 -> Event -- new events to watch
157 -> IO Bool
158
159 , _beDelete :: a -> IO ()
160 }
161
162 backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
163 -> (a -> Fd -> Event -> Event -> IO Bool)
164 -> (a -> Fd -> Event -> IO Bool)
165 -> (a -> IO ())
166 -> a
167 -> Backend
168 backend bPoll bModifyFd bModifyFdOnce bDelete state =
169 Backend state bPoll bModifyFd bModifyFdOnce bDelete
170 {-# INLINE backend #-}
171
172 poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
173 poll (Backend bState bPoll _ _ _) = bPoll bState
174 {-# INLINE poll #-}
175
176 -- | Returns 'True' if the modification succeeded.
177 -- Returns 'False' if this backend does not support
178 -- event notifications on this type of file.
179 modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool
180 modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState
181 {-# INLINE modifyFd #-}
182
183 -- | Returns 'True' if the modification succeeded.
184 -- Returns 'False' if this backend does not support
185 -- event notifications on this type of file.
186 modifyFdOnce :: Backend -> Fd -> Event -> IO Bool
187 modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState
188 {-# INLINE modifyFdOnce #-}
189
190 delete :: Backend -> IO ()
191 delete (Backend bState _ _ _ bDelete) = bDelete bState
192 {-# INLINE delete #-}
193
194 -- | Throw an 'IOError' corresponding to the current value of
195 -- 'getErrno' if the result value of the 'IO' action is -1 and
196 -- 'getErrno' is not 'eINTR'. If the result value is -1 and
197 -- 'getErrno' returns 'eINTR' 0 is returned. Otherwise the result
198 -- value is returned.
199 throwErrnoIfMinus1NoRetry :: (Eq a, Num a) => String -> IO a -> IO a
200 throwErrnoIfMinus1NoRetry loc f = do
201 res <- f
202 if res == -1
203 then do
204 err <- getErrno
205 if err == eINTR then return 0 else throwErrno loc
206 else return res