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

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

import qualified GHC.Event.Internal as E



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

import Data.Bits (Bits(..), FiniteBits(..))
import Data.Int
import Data.Maybe ( catMaybes )
import Data.Word (Word16, Word32)
import Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL,
                        eNOTSUP, getErrno, throwErrno)
import Foreign.C.Types
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (withArrayLen)
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Storable (Storable(..))
import GHC.Base
import GHC.Enum (toEnum)
import GHC.Num (Num(..))
import GHC.Real (quotRem, 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 53 "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 64 "libraries/base/GHC/Event/KQueue.hsc" #-}

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

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

data KQueue = KQueue {
      kqueueFd     :: {-# UNPACK #-} !KQueueFd
    , kqueueEvents :: {-# UNPACK #-} !(A.Array Event)
    }

new :: IO E.Backend
new = do
  kqfd <- kqueue
  events <- A.new 64
  let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events)
  return be

delete :: KQueue -> IO ()
delete kq = do
  _ <- c_close . fromKQueueFd . kqueueFd $ kq
  return ()

modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool
modifyFd kq fd oevt nevt = kqueueControl (kqueueFd kq) evs
  where
    evs
      | nevt == mempty = toEvents fd (toFilter oevt) flagDelete noteEOF
      | otherwise      = toEvents fd (toFilter nevt) flagAdd noteEOF

toFilter :: E.Event -> [Filter]
toFilter e = catMaybes [ check E.evtRead filterRead, check E.evtWrite filterWrite ]
  where
    check e' f = if e `E.eventIs` e' then Just f else Nothing

modifyFdOnce :: KQueue -> Fd -> E.Event -> IO Bool
modifyFdOnce kq fd evt =
    kqueueControl (kqueueFd kq) (toEvents fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF)

poll :: KQueue
     -> Maybe Timeout
     -> (Fd -> E.Event -> IO ())
     -> IO Int
poll kq mtimeout f = do
    let events = kqueueEvents kq
        fd = kqueueFd kq

    n <- A.unsafeLoad events $ \es cap -> case mtimeout of
      Just timeout -> kqueueWait fd es cap $ fromTimeout timeout
      Nothing      -> kqueueWaitNonBlock fd es cap

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

newtype KQueueFd = KQueueFd {
      fromKQueueFd :: CInt
    } deriving ( Eq   -- ^ @since 4.4.0.0
               , Show -- ^ @since 4.4.0.0
               )

data Event = KEvent {
      ident  :: {-# UNPACK #-} !CUIntPtr
    , filter :: {-# UNPACK #-} !Filter
    , flags  :: {-# UNPACK #-} !Flag
    , fflags :: {-# UNPACK #-} !FFlag

{-# LINE 139 "libraries/base/GHC/Event/KQueue.hsc" #-}
    , data_  :: {-# UNPACK #-} !CIntPtr

{-# LINE 141 "libraries/base/GHC/Event/KQueue.hsc" #-}
    , udata  :: {-# UNPACK #-} !(Ptr ())
    } deriving Show -- ^ @since 4.4.0.0

toEvents :: Fd -> [Filter] -> Flag -> FFlag -> [Event]
toEvents fd flts flag fflag = map (\filt -> KEvent (fromIntegral fd) filt flag fflag 0 nullPtr) flts

-- | @since 4.3.1.0
instance Storable Event where
    sizeOf _ = (32)
{-# LINE 150 "libraries/base/GHC/Event/KQueue.hsc" #-}
    alignment _ = alignment (undefined :: CInt)

    peek ptr = do
        ident'  <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
{-# LINE 154 "libraries/base/GHC/Event/KQueue.hsc" #-}
        filter' <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
{-# LINE 155 "libraries/base/GHC/Event/KQueue.hsc" #-}
        flags'  <- (\hsc_ptr -> peekByteOff hsc_ptr 10) ptr
{-# LINE 156 "libraries/base/GHC/Event/KQueue.hsc" #-}
        fflags' <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr
{-# LINE 157 "libraries/base/GHC/Event/KQueue.hsc" #-}
        data'   <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
{-# LINE 158 "libraries/base/GHC/Event/KQueue.hsc" #-}
        udata'  <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
{-# LINE 159 "libraries/base/GHC/Event/KQueue.hsc" #-}
        let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data'
                         udata'
        return ev

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

newtype FFlag = FFlag Word32
    deriving ( Eq       -- ^ @since 4.4.0.0
             , Show     -- ^ @since 4.4.0.0
             , Storable -- ^ @since 4.4.0.0
             )

noteEOF  :: FFlag
noteEOF  = FFlag 0

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


{-# LINE 184 "libraries/base/GHC/Event/KQueue.hsc" #-}
newtype Flag = Flag Word16

{-# LINE 186 "libraries/base/GHC/Event/KQueue.hsc" #-}
    deriving ( Bits       -- ^ @since 4.7.0.0
             , FiniteBits -- ^ @since 4.7.0.0
             , Eq         -- ^ @since 4.4.0.0
             , Num        -- ^ @since 4.7.0.0
             , Show       -- ^ @since 4.4.0.0
             , Storable   -- ^ @since 4.4.0.0
             )

flagAdd      :: Flag
flagAdd      = Flag 1
flagDelete   :: Flag
flagDelete   = Flag 2
flagOneshot  :: Flag
flagOneshot  = Flag 16

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


{-# LINE 203 "libraries/base/GHC/Event/KQueue.hsc" #-}
newtype Filter = Filter Int16

{-# LINE 205 "libraries/base/GHC/Event/KQueue.hsc" #-}
    deriving ( Eq       -- ^ @since 4.4.0.0
             , Num      -- ^ @since 4.4.0.0
             , Show     -- ^ @since 4.4.0.0
             , Storable -- ^ @since 4.4.0.0
             )

filterRead :: Filter
filterRead = Filter (-1)
{-# LINE 213 "libraries/base/GHC/Event/KQueue.hsc" #-}
filterWrite :: Filter
filterWrite  = Filter (-2)
{-# LINE 215 "libraries/base/GHC/Event/KQueue.hsc" #-}

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

-- | @since 4.3.1.0
instance Storable TimeSpec where
    sizeOf _ = (16)
{-# LINE 224 "libraries/base/GHC/Event/KQueue.hsc" #-}
    alignment _ = alignment (undefined :: CInt)

    peek ptr = do
        tv_sec'  <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
{-# LINE 228 "libraries/base/GHC/Event/KQueue.hsc" #-}
        tv_nsec' <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
{-# LINE 229 "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 234 "libraries/base/GHC/Event/KQueue.hsc" #-}
        (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (tv_nsec ts)
{-# LINE 235 "libraries/base/GHC/Event/KQueue.hsc" #-}

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

kqueueControl :: KQueueFd -> [Event] -> IO Bool
kqueueControl kfd evts =
    withTimeSpec (TimeSpec 0 0) $ \tp ->
        withArrayLen evts $ \evlen evp -> do
            res <- kevent False kfd evp evlen nullPtr 0 tp
            if res == -1
              then do
               err <- getErrno
               case err of
                 _ | err == eINTR  -> return True
                 _ | err == eINVAL -> return False
                 _ | err == eNOTSUP -> return False
                 _                 -> throwErrno "kevent"
              else return True

kqueueWait :: KQueueFd -> Ptr Event -> Int -> TimeSpec -> IO Int
kqueueWait fd es cap tm =
    fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
    withTimeSpec tm $ kevent True fd nullPtr 0 es cap

kqueueWaitNonBlock :: KQueueFd -> Ptr Event -> Int -> IO Int
kqueueWaitNonBlock fd es cap =
    fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
    withTimeSpec (TimeSpec 0 0) $ kevent False fd nullPtr 0 es cap

-- TODO: We cannot retry on EINTR as the timeout would be wrong.
-- Perhaps we should just return without calling any callbacks.
kevent :: Bool -> KQueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
       -> IO CInt
kevent safe k chs chlen evs evlen ts
  | safe      = c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
  | otherwise = c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts

withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a
withTimeSpec ts f
  | tv_sec ts < 0 = f nullPtr
  | otherwise     = 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, nanosec) = s `quotRem` 1000000000

    nanosec', sec' :: Int
    sec' = fromIntegral sec
    nanosec' = fromIntegral nanosec

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

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


{-# LINE 297 "libraries/base/GHC/Event/KQueue.hsc" #-}
foreign import capi safe "sys/event.h kevent"
    c_kevent :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
             -> Ptr TimeSpec -> IO CInt

foreign import ccall unsafe "kevent"
    c_kevent_unsafe :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
                    -> Ptr TimeSpec -> IO CInt

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


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