Internal.hs

{-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}

module System.Event.Internal
    (
    -- * Event back end
      Backend
    , backend
    , delete
    , poll
    , modifyFd
    -- * Event type
    , Event
    , evtRead
    , evtWrite
    , eventIs
    -- * Timeout type
    , Timeout(..)
    -- * Helpers
    , throwErrnoIfMinus1NoRetry
    ) where

import Data.Bits ((.|.), (.&.))
import Data.List (foldl', intercalate)
import Data.Monoid (Monoid(..))
import Foreign.C.Error (eINTR, getErrno, throwErrno)
import System.Posix.Types (Fd)
import GHC.Base
import GHC.Num (Num(..))
import GHC.Show (Show(..))
import GHC.List (filter, null)

-- | An I/O event.
newtype Event = Event Int
    deriving (Eq)

evtNothing :: Event
evtNothing = Event 0
{-# INLINE evtNothing #-}

evtRead :: Event
evtRead = Event 1
{-# INLINE evtRead #-}

evtWrite :: Event
evtWrite = Event 2
{-# INLINE evtWrite #-}

eventIs :: Event -> Event -> Bool
eventIs (Event a) (Event b) = a .&. b /= 0

instance Show Event where
    show e = '[' : (intercalate "," . filter (not . null) $
                    [evtRead `so` "evtRead", evtWrite `so` "evtWrite"]) ++ "]"
        where ev `so` disp | e `eventIs` ev = disp
                           | otherwise      = ""

instance Monoid Event where
    mempty  = evtNothing
    mappend = evtCombine
    mconcat = evtConcat

evtCombine :: Event -> Event -> Event
evtCombine (Event a) (Event b) = Event (a .|. b)
{-# INLINE evtCombine #-}

evtConcat :: [Event] -> Event
evtConcat = foldl' evtCombine evtNothing
{-# INLINE evtConcat #-}

-- | A type alias for timeouts, specified in seconds.
data Timeout = Timeout {-# UNPACK #-} !Double
             | Forever
               deriving (Show)

-- | Event notification backend.
data Backend = forall a. Backend {
      _beState :: !a

    -- | Poll backend for new events.  The provided callback is called
    -- once per file descriptor with new events.
    , _bePoll :: a                          -- backend state
              -> Timeout                    -- timeout in milliseconds
              -> (Fd -> Event -> IO ())     -- I/O callback
              -> IO ()

    -- | Register, modify, or unregister interest in the given events
    -- on the given file descriptor.
    , _beModifyFd :: a
                  -> Fd       -- file descriptor
                  -> Event    -- old events to watch for ('mempty' for new)
                  -> Event    -- new events to watch for ('mempty' to delete)
                  -> IO ()

    , _beDelete :: a -> IO ()
    }

backend :: (a -> Timeout -> (Fd -> Event -> IO ()) -> IO ())
        -> (a -> Fd -> Event -> Event -> IO ())
        -> (a -> IO ())
        -> a
        -> Backend
backend bPoll bModifyFd bDelete state = Backend state bPoll bModifyFd bDelete
{-# INLINE backend #-}

poll :: Backend -> Timeout -> (Fd -> Event -> IO ()) -> IO ()
poll (Backend bState bPoll _ _) = bPoll bState
{-# INLINE poll #-}

modifyFd :: Backend -> Fd -> Event -> Event -> IO ()
modifyFd (Backend bState _ bModifyFd _) = bModifyFd bState
{-# INLINE modifyFd #-}

delete :: Backend -> IO ()
delete (Backend bState _ _ bDelete) = bDelete bState
{-# INLINE delete #-}

-- | Throw an 'IOError' corresponding to the current value of
-- 'getErrno' if the result value of the 'IO' action is -1 and
-- 'getErrno' is not 'eINTR'.  If the result value is -1 and
-- 'getErrno' returns 'eINTR' 0 is returned.  Otherwise the result
-- value is returned.
throwErrnoIfMinus1NoRetry :: Num a => String -> IO a -> IO a
throwErrnoIfMinus1NoRetry loc f = do
    res <- f
    if res == -1
        then do
            err <- getErrno
            if err == eINTR then return 0 else throwErrno loc
        else return res