System/Event/Internal.hs

   1 {-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}
   2
   3 module System.Event.Internal
   4     (
   5     -- * Event back end
   6       Backend
   7     , backend
   8     , delete
   9     , poll
  10     , modifyFd
  11     -- * Event type
  12     , Event
  13     , evtRead
  14     , evtWrite
  15     , evtClose
  16     , eventIs
  17     -- * Timeout type
  18     , Timeout(..)
  19     -- * Helpers
  20     , throwErrnoIfMinus1NoRetry
  21     ) where
  22
  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)
  28 import GHC.Base
  29 import GHC.Num (Num(..))
  30 import GHC.Show (Show(..))
  31 import GHC.List (filter, null)
  32
  33 -- | An I\/O event.
  34 newtype Event = Event Int
  35     deriving (Eq)
  36
  37 evtNothing :: Event
  38 evtNothing = Event 0
  39 {-# INLINE evtNothing #-}
  40
  41 -- | Data is available to be read.
  42 evtRead :: Event
  43 evtRead = Event 1
  44 {-# INLINE evtRead #-}
  45
  46 -- | The file descriptor is ready to accept a write.
  47 evtWrite :: Event
  48 evtWrite = Event 2
  49 {-# INLINE evtWrite #-}
  50
  51 -- | Another thread closed the file descriptor.
  52 evtClose :: Event
  53 evtClose = Event 4
  54 {-# INLINE evtClose #-}
  55
  56 eventIs :: Event -> Event -> Bool
  57 eventIs (Event a) (Event b) = a .&. b /= 0
  58
  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
  65                            | otherwise      = ""
  66
  67 instance Monoid Event where
  68     mempty  = evtNothing
  69     mappend = evtCombine
  70     mconcat = evtConcat
  71
  72 evtCombine :: Event -> Event -> Event
  73 evtCombine (Event a) (Event b) = Event (a .|. b)
  74 {-# INLINE evtCombine #-}
  75
  76 evtConcat :: [Event] -> Event
  77 evtConcat = foldl' evtCombine evtNothing
  78 {-# INLINE evtConcat #-}
  79
  80 -- | A type alias for timeouts, specified in seconds.
  81 data Timeout = Timeout {-# UNPACK #-} !Double
  82              | Forever
  83                deriving (Show)
  84
  85 -- | Event notification backend.
  86 data Backend = forall a. Backend {
  87       _beState :: !a
  88
  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
  94               -> IO ()
  95
  96     -- | Register, modify, or unregister interest in the given events
  97     -- on the given file descriptor.
  98     , _beModifyFd :: a
  99                   -> Fd       -- file descriptor
 100                   -> Event    -- old events to watch for ('mempty' for new)
 101                   -> Event    -- new events to watch for ('mempty' to delete)
 102                   -> IO ()
 103
 104     , _beDelete :: a -> IO ()
 105     }
 106
 107 backend :: (a -> Timeout -> (Fd -> Event -> IO ()) -> IO ())
 108         -> (a -> Fd -> Event -> Event -> IO ())
 109         -> (a -> IO ())
 110         -> a
 111         -> Backend
 112 backend bPoll bModifyFd bDelete state = Backend state bPoll bModifyFd bDelete
 113 {-# INLINE backend #-}
 114
 115 poll :: Backend -> Timeout -> (Fd -> Event -> IO ()) -> IO ()
 116 poll (Backend bState bPoll _ _) = bPoll bState
 117 {-# INLINE poll #-}
 118
 119 modifyFd :: Backend -> Fd -> Event -> Event -> IO ()
 120 modifyFd (Backend bState _ bModifyFd _) = bModifyFd bState
 121 {-# INLINE modifyFd #-}
 122
 123 delete :: Backend -> IO ()
 124 delete (Backend bState _ _ bDelete) = bDelete bState
 125 {-# INLINE delete #-}
 126
 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
 134     res <- f
 135     if res == -1
 136         then do
 137             err <- getErrno
 138             if err == eINTR then return 0 else throwErrno loc
 139         else return res