{-# LINE 1 "libraries/base/./GHC/Event/KQueue.hsc" #-}
{-# LANGUAGE Trustworthy #-}
{-# LINE 2 "libraries/base/./GHC/Event/KQueue.hsc" #-}
{-# LANGUAGE CPP
           , ForeignFunctionInterface
           , GeneralizedNewtypeDeriving
           , NoImplicitPrelude
           , RecordWildCards
           , BangPatterns
  #-}

module GHC.Event.KQueue
    (
      new
    , available
    ) where

import qualified GHC.Event.Internal as E


{-# LINE 19 "libraries/base/./GHC/Event/KQueue.hsc" #-}

{-# LINE 29 "libraries/base/./GHC/Event/KQueue.hsc" #-}

import Control.Concurrent.MVar (MVar, newMVar, swapMVar, withMVar)
import Control.Monad (when, unless)
import Data.Bits (Bits(..))
import Data.Word (Word16, Word32)
import Foreign.C.Error (throwErrnoIfMinus1)
import Foreign.C.Types
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Storable (Storable(..))
import GHC.Base
import GHC.Enum (toEnum)
import GHC.Err (undefined)
import GHC.Num (Num(..))
import GHC.Real (ceiling, floor, fromIntegral)
import GHC.Show (Show(show))
import GHC.Event.Internal (Timeout(..))
import System.Posix.Internals (c_close)
import System.Posix.Types (Fd(..))
import qualified GHC.Event.Array as A


{-# LINE 51 "libraries/base/./GHC/Event/KQueue.hsc" #-}
import Data.Int (Int64)
import Data.Word (Word64)

{-# LINE 54 "libraries/base/./GHC/Event/KQueue.hsc" #-}


{-# LINE 56 "libraries/base/./GHC/Event/KQueue.hsc" #-}

{-# LINE 57 "libraries/base/./GHC/Event/KQueue.hsc" #-}

{-# LINE 58 "libraries/base/./GHC/Event/KQueue.hsc" #-}

-- Handle brokenness on some BSD variants, notably OS X up to at least
-- 10.6.  If NOTE_EOF isn't available, we have no way to receive a
-- notification from the kernel when we reach EOF on a plain file.

{-# LINE 65 "libraries/base/./GHC/Event/KQueue.hsc" #-}

available :: Bool
available = True
{-# INLINE available #-}

------------------------------------------------------------------------
-- Exported interface

data EventQueue = EventQueue {
      eqFd       :: {-# UNPACK #-} !QueueFd
    , eqChanges  :: {-# UNPACK #-} !(MVar (A.Array Event))
    , eqEvents   :: {-# UNPACK #-} !(A.Array Event)
    }

new :: IO E.Backend
new = do
  qfd <- kqueue
  changesArr <- A.empty
  changes <- newMVar changesArr 
  events <- A.new 64
  let !be = E.backend poll modifyFd delete (EventQueue qfd changes events)
  return be

delete :: EventQueue -> IO ()
delete q = do
  _ <- c_close . fromQueueFd . eqFd $ q
  return ()

modifyFd :: EventQueue -> Fd -> E.Event -> E.Event -> IO ()
modifyFd q fd oevt nevt = withMVar (eqChanges q) $ \ch -> do
  let addChange filt flag = A.snoc ch $ event fd filt flag noteEOF
  when (oevt `E.eventIs` E.evtRead)  $ addChange filterRead flagDelete
  when (oevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagDelete
  when (nevt `E.eventIs` E.evtRead)  $ addChange filterRead flagAdd
  when (nevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagAdd

poll :: EventQueue
     -> Timeout
     -> (Fd -> E.Event -> IO ())
     -> IO ()
poll EventQueue{..} tout f = do
    changesArr <- A.empty
    changes <- swapMVar eqChanges changesArr
    changesLen <- A.length changes
    len <- A.length eqEvents
    when (changesLen > len) $ A.ensureCapacity eqEvents (2 * changesLen)
    n <- A.useAsPtr changes $ \changesPtr chLen ->
           A.unsafeLoad eqEvents $ \evPtr evCap ->
             withTimeSpec (fromTimeout tout) $
               kevent eqFd changesPtr chLen evPtr evCap

    unless (n == 0) $ do
        cap <- A.capacity eqEvents
        when (n == cap) $ A.ensureCapacity eqEvents (2 * cap)
        A.forM_ eqEvents $ \e -> f (fromIntegral (ident e)) (toEvent (filter e))

------------------------------------------------------------------------
-- FFI binding

newtype QueueFd = QueueFd {
      fromQueueFd :: CInt
    } deriving (Eq, Show)


{-# LINE 129 "libraries/base/./GHC/Event/KQueue.hsc" #-}
data Event = KEvent64 {
      ident  :: {-# UNPACK #-} !Word64
    , filter :: {-# UNPACK #-} !Filter
    , flags  :: {-# UNPACK #-} !Flag
    , fflags :: {-# UNPACK #-} !FFlag
    , data_  :: {-# UNPACK #-} !Int64
    , udata  :: {-# UNPACK #-} !Word64
    , ext0   :: {-# UNPACK #-} !Word64
    , ext1   :: {-# UNPACK #-} !Word64
    } deriving Show

event :: Fd -> Filter -> Flag -> FFlag -> Event
event fd filt flag fflag = KEvent64 (fromIntegral fd) filt flag fflag 0 0 0 0

instance Storable Event where
    sizeOf _ = (48)
{-# LINE 145 "libraries/base/./GHC/Event/KQueue.hsc" #-}
    alignment _ = alignment (undefined :: CInt)

    peek ptr = do
        ident'  <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
{-# LINE 149 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        filter' <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
{-# LINE 150 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        flags'  <- (\hsc_ptr -> peekByteOff hsc_ptr 10) ptr
{-# LINE 151 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        fflags' <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr
{-# LINE 152 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        data'   <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
{-# LINE 153 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        udata'  <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
{-# LINE 154 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        ext0'   <- (\hsc_ptr -> peekByteOff hsc_ptr 32) ptr
{-# LINE 155 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        ext1'   <- (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr
{-# LINE 156 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        let !ev = KEvent64 ident' (Filter filter') (Flag flags') fflags' data'
                           udata' ext0' ext1'
        return ev

    poke ptr ev = do
        (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (ident ev)
{-# LINE 162 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (filter ev)
{-# LINE 163 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 10) ptr (flags ev)
{-# LINE 164 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr (fflags ev)
{-# LINE 165 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (data_ ev)
{-# LINE 166 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr (udata ev)
{-# LINE 167 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 32) ptr (ext0 ev)
{-# LINE 168 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 40) ptr (ext1 ev)
{-# LINE 169 "libraries/base/./GHC/Event/KQueue.hsc" #-}

{-# LINE 205 "libraries/base/./GHC/Event/KQueue.hsc" #-}

newtype FFlag = FFlag Word32
    deriving (Eq, Show, Storable)

noteEOF  :: FFlag
noteEOF  = FFlag 0

{-# LINE 212 "libraries/base/./GHC/Event/KQueue.hsc" #-}

newtype Flag = Flag Word16
    deriving (Eq, Show, Storable)

flagAdd      :: Flag
flagAdd      = Flag 1
flagDelete   :: Flag
flagDelete   = Flag 2

{-# LINE 220 "libraries/base/./GHC/Event/KQueue.hsc" #-}

newtype Filter = Filter Word16
    deriving (Bits, Eq, Num, Show, Storable)

filterRead    :: Filter
filterRead    = Filter (-1)
filterWrite   :: Filter
filterWrite   = Filter (-2)

{-# LINE 228 "libraries/base/./GHC/Event/KQueue.hsc" #-}

data TimeSpec = TimeSpec {
      tv_sec  :: {-# UNPACK #-} !CTime
    , tv_nsec :: {-# UNPACK #-} !CLong
    }

instance Storable TimeSpec where
    sizeOf _ = (8)
{-# LINE 236 "libraries/base/./GHC/Event/KQueue.hsc" #-}
    alignment _ = alignment (undefined :: CInt)

    peek ptr = do
        tv_sec'  <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
{-# LINE 240 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        tv_nsec' <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
{-# LINE 241 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        let !ts = TimeSpec tv_sec' tv_nsec'
        return ts

    poke ptr ts = do
        (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (tv_sec ts)
{-# LINE 246 "libraries/base/./GHC/Event/KQueue.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (tv_nsec ts)
{-# LINE 247 "libraries/base/./GHC/Event/KQueue.hsc" #-}

kqueue :: IO QueueFd
kqueue = QueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue

-- TODO: We cannot retry on EINTR as the timeout would be wrong.
-- Perhaps we should just return without calling any callbacks.
kevent :: QueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
       -> IO Int
kevent k chs chlen evs evlen ts
    = fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $

{-# LINE 258 "libraries/base/./GHC/Event/KQueue.hsc" #-}
      c_kevent64 k chs (fromIntegral chlen) evs (fromIntegral evlen) 0 ts

{-# LINE 262 "libraries/base/./GHC/Event/KQueue.hsc" #-}

withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a
withTimeSpec ts f =
    if tv_sec ts < 0 then
        f nullPtr
      else
        alloca $ \ptr -> poke ptr ts >> f ptr

fromTimeout :: Timeout -> TimeSpec
fromTimeout Forever     = TimeSpec (-1) (-1)
fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec)
  where
    sec :: Int
    sec     = floor s

    nanosec :: Int
    nanosec = ceiling $ (s - fromIntegral sec) * 1000000000

toEvent :: Filter -> E.Event
toEvent (Filter f)
    | f == (-1) = E.evtRead
{-# LINE 283 "libraries/base/./GHC/Event/KQueue.hsc" #-}
    | f == (-2) = E.evtWrite
{-# LINE 284 "libraries/base/./GHC/Event/KQueue.hsc" #-}
    | otherwise = error $ "toEvent: unknown filter " ++ show f

foreign import ccall unsafe "kqueue"
    c_kqueue :: IO CInt


{-# LINE 290 "libraries/base/./GHC/Event/KQueue.hsc" #-}
foreign import ccall safe "kevent64"
    c_kevent64 :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt -> CUInt
               -> Ptr TimeSpec -> IO CInt

{-# LINE 300 "libraries/base/./GHC/Event/KQueue.hsc" #-}


{-# LINE 302 "libraries/base/./GHC/Event/KQueue.hsc" #-}