{-# OPTIONS -ffi #-}
{-# INCLUDE <event.h> #-}

module Event where

import Foreign
import Foreign.Ptr
import Foreign.C.Types
import System.Posix.Types
import Foreign.Marshal.Alloc

#include <event.h>

-- Possible event types
type CEventType = CShort

#{enum CEventType, ,
    ev_timeout = EV_TIMEOUT,
    ev_read    = EV_READ,
    ev_write   = EV_WRITE,
    ev_signal  = EV_SIGNAL,
    ev_persist = EV_PERSIST
}


data CEvent = CEvent -- corresponds to 'struct event'
type CEventPtr = Ptr CEvent
type CEventBasePtr = Ptr ()

instance Storable CEvent where
    sizeOf _ = (#size struct event)
    alignment _ = alignment (undefined :: CInt)

-- Data type corresponding to 'struct timeval'
data TimeVal = TimeVal {
    secs  :: CLong,
    usecs :: CLong
}

type TimeValPtr = Ptr TimeVal

instance Storable TimeVal where
    sizeOf _ = (#size struct timeval)
    alignment _ = alignment (undefined :: CInt)
    peek ptr = do
        s <- (#peek struct timeval, tv_sec) ptr
        u <- (#peek struct timeval, tv_usec) ptr
        return TimeVal { secs=s, usecs=u }
    poke ptr (TimeVal s u) = do
        (#poke struct timeval, tv_sec) ptr s
        (#poke struct timeval, tv_usec) ptr u

-- Callback function type
type CCallback a = (CInt -> CShort -> Ptr a -> IO ())
type CCallbackPtr a = FunPtr (CCallback a)

-- libevent C-API

foreign import ccall "event_init"
    c_event_init :: IO CEventBasePtr

foreign import ccall "event_set"
    c_event_set :: CEventPtr -> CInt -> CShort -> CCallbackPtr a -> Ptr a -> IO ()

foreign import ccall "event_add"
    c_event_add :: CEventPtr -> TimeValPtr -> IO CInt

foreign import ccall "event_del"
    c_event_del :: CEventPtr -> IO CInt

foreign import ccall "event_dispatch"
    c_event_dispatch :: IO CInt

-- Wrapper functionality

data EventType = TimeoutEvent | ReadEvent | WriteEvent | SignalEvent | PersistEvent
    deriving (Eq, Ord, Show)

toEventType :: CEventType -> EventType
toEventType e | e == ev_timeout = TimeoutEvent
              | e == ev_read    = ReadEvent
              | e == ev_write   = WriteEvent
              | e == ev_signal  = SignalEvent
              | e == ev_persist = PersistEvent

fromEventType :: EventType -> CEventType
fromEventType TimeoutEvent = ev_timeout
fromEventType ReadEvent    = ev_read
fromEventType WriteEvent   = ev_write
fromEventType SignalEvent  = ev_signal
fromEventType PersistEvent = ev_persist

sumEventTypes :: [EventType] -> CEventType
sumEventTypes es = foldr (\e x -> e .|. x) 0 $ map fromEventType es

type CallbackFn a = (Fd -> EventType -> a -> IO ())

mkCallback :: Storable a => CallbackFn a -> CCallback a
mkCallback f = \i e px -> do x <- peek px
                             f (Fd i) (toEventType e) x

foreign import ccall "wrapper"
    wrapCallback :: CCallback a -> IO (CCallbackPtr a)


-- Public API

data Storable a => Event a = Event (ForeignPtr CEvent) (ForeignPtr a)

init :: IO ()
init = c_event_init >> return ()

createEvent :: Storable a => Fd -> [EventType] -> CallbackFn a -> a -> IO (Event a)
createEvent (Fd i) et fn x = do
    ep <- mallocForeignPtr
    xp <- mallocForeignPtr
    cb <- wrapCallback $ mkCallback fn
    withForeignPtr ep $ \eptr -> 
        withForeignPtr xp $ \xptr ->
            c_event_set eptr (fromIntegral i) (sumEventTypes et) cb xptr
    return (Event ep xp)

addEvent :: Storable a => Event a -> Maybe TimeVal -> IO Int
addEvent (Event ep _) tv = do
    withForeignPtr ep $ \p ->
        case tv of
            Just t  -> with t $ \tp -> c_event_add p tp >>= \r -> return $ fromIntegral r
            Nothing -> c_event_add p nullPtr >>= \r -> return $ fromIntegral r

dispatch :: IO Int
dispatch = c_event_dispatch >>= \r -> return $ fromIntegral r