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     , eventIs
  16     -- * Timeout type
  17     , Timeout(..)
  18     -- * Helpers
  19     , throwErrnoIfMinus1NoRetry
  20     ) where
  21
  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)
  27 import GHC.Base
  28 import GHC.Num (Num(..))
  29 import GHC.Show (Show(..))
  30 import GHC.List (filter, null)
  31
  32 -- | An I/O event.
  33 newtype Event = Event Int
  34     deriving (Eq)
  35
  36 evtNothing :: Event
  37 evtNothing = Event 0
  38 {-# INLINE evtNothing #-}
  39
  40 evtRead :: Event
  41 evtRead = Event 1
  42 {-# INLINE evtRead #-}
  43
  44 evtWrite :: Event
  45 evtWrite = Event 2
  46 {-# INLINE evtWrite #-}
  47
  48 eventIs :: Event -> Event -> Bool
  49 eventIs (Event a) (Event b) = a .&. b /= 0
  50
  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
  55                            | otherwise      = ""
  56
  57 instance Monoid Event where
  58     mempty  = evtNothing
  59     mappend = evtCombine
  60     mconcat = evtConcat
  61
  62 evtCombine :: Event -> Event -> Event
  63 evtCombine (Event a) (Event b) = Event (a .|. b)
  64 {-# INLINE evtCombine #-}
  65
  66 evtConcat :: [Event] -> Event
  67 evtConcat = foldl' evtCombine evtNothing
  68 {-# INLINE evtConcat #-}
  69
  70 -- | A type alias for timeouts, specified in seconds.
  71 data Timeout = Timeout {-# UNPACK #-} !Double
  72              | Forever
  73                deriving (Show)
  74
  75 -- | Event notification backend.
  76 data Backend = forall a. Backend {
  77       _beState :: !a
  78
  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
  84               -> IO ()
  85
  86     -- | Register, modify, or unregister interest in the given events
  87     -- on the given file descriptor.
  88     , _beModifyFd :: a
  89                   -> Fd       -- file descriptor
  90                   -> Event    -- old events to watch for ('mempty' for new)
  91                   -> Event    -- new events to watch for ('mempty' to delete)
  92                   -> IO ()
  93
  94     , _beDelete :: a -> IO ()
  95     }
  96
  97 backend :: (a -> Timeout -> (Fd -> Event -> IO ()) -> IO ())
  98         -> (a -> Fd -> Event -> Event -> IO ())
  99         -> (a -> IO ())
 100         -> a
 101         -> Backend
 102 backend bPoll bModifyFd bDelete state = Backend state bPoll bModifyFd bDelete
 103 {-# INLINE backend #-}
 104
 105 poll :: Backend -> Timeout -> (Fd -> Event -> IO ()) -> IO ()
 106 poll (Backend bState bPoll _ _) = bPoll bState
 107 {-# INLINE poll #-}
 108
 109 modifyFd :: Backend -> Fd -> Event -> Event -> IO ()
 110 modifyFd (Backend bState _ bModifyFd _) = bModifyFd bState
 111 {-# INLINE modifyFd #-}
 112
 113 delete :: Backend -> IO ()
 114 delete (Backend bState _ _ bDelete) = bDelete bState
 115 {-# INLINE delete #-}
 116
 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
 124     res <- f
 125     if res == -1
 126         then do
 127             err <- getErrno
 128             if err == eINTR then return 0 else throwErrno loc
 129         else return res