-- GENERATED by C->Haskell Compiler, version 0.16.3 Crystal Seed, 24 Jan 2009 (Haskell)
-- Edit the ORIGNAL .chs file instead!


{-# LINE 1 "src/System/KQueue.chs" #-}{-# LANGUAGE DeriveDataTypeable
           , EmptyDataDecls
           , ForeignFunctionInterface
           #-}
-- | This module contains a low-level binding to the kqueue interface.
-- It stays close to the C API, changing the types to more native
-- Haskell types, but not significantly changing it.
-- See the kqueue man page or the examples in @examples/@ for usage
-- information.
-- For a higher-level binding, see "System.KQueue.HighLevel".
module System.KQueue
  ( KQueue
  , kqueue
  , KEvent (..)
  , Filter (..)
  , Flag (..)
  , FFlag (..)
  , kevent
  , KQueueException
  ) where


import Control.Applicative ( (<$>), (<*>) )
import Control.Exception   ( Exception, throwIO )
import Data.List           ( foldl' )
import Data.Maybe          ( mapMaybe )
import Data.Time.Clock     ( NominalDiffTime )
import Data.Typeable       ( Typeable )
import Foreign             ( (.|.)
                           , Ptr
                           , Storable (..)
                           , allocaArray
                           , bit
                           , bitSize
                           , maybeWith
                           , testBit
                           , peekArray
                           , with
                           , withArray
                           )
import Foreign.C           ( CInt (..) )
import Foreign.C           ( CLong
                           , CShort
                           , CTime
                           , CUInt
                           , CULong
                           , CUShort
                           )

-- | A kernel event queue.
newtype KQueue = KQueue CInt -- The descriptor

-- | Create a new KQueue.
kqueue :: IO KQueue
kqueue = KQueue <$> kqueue_
{-# LINE 61 "src/System/KQueue.chs" #-}

-- | A kernel event.
data KEvent = KEvent
  { ident    :: CULong  -- ^ The identifier for the event, often a file descriptor.
  , evfilter :: Filter  -- ^ The kernel filter (type of event).
  , flags    :: [Flag]  -- ^ Actions to perform on the event.
  , fflags   :: [FFlag] -- ^ Filter-specific flags.
  , data_    :: CLong   -- ^ Filter-specific data value.
  , udata    :: Ptr ()  -- ^ User-defined data, passed through unchanged.
  } deriving (Show, Eq)

-- TODO: nicer types for ident, data_ and udata.

-- | The types of kernel events.
data Filter = EvfiltRead
            | EvfiltWrite
            | EvfiltAio
            | EvfiltVnode
            | EvfiltProc
            | EvfiltSignal
            | EvfiltTimer
            deriving (Show,Eq)
instance Enum Filter where
  fromEnum EvfiltRead = (-1)
  fromEnum EvfiltWrite = (-2)
  fromEnum EvfiltAio = (-3)
  fromEnum EvfiltVnode = (-4)
  fromEnum EvfiltProc = (-5)
  fromEnum EvfiltSignal = (-6)
  fromEnum EvfiltTimer = (-7)

  toEnum (-1) = EvfiltRead
  toEnum (-2) = EvfiltWrite
  toEnum (-3) = EvfiltAio
  toEnum (-4) = EvfiltVnode
  toEnum (-5) = EvfiltProc
  toEnum (-6) = EvfiltSignal
  toEnum (-7) = EvfiltTimer
  toEnum unmatched = error ("Filter.toEnum: Cannot match " ++ show unmatched)

{-# LINE 90 "src/System/KQueue.chs" #-}

-- | The actions to perform on the event.
data Flag = EvAdd
          | EvEnable
          | EvDisable
          | EvDelete
          | EvReceipt
          | EvOneshot
          | EvClear
          | EvEof
          | EvError
          deriving (Show,Eq)
instance Enum Flag where
  fromEnum EvAdd = 1
  fromEnum EvEnable = 4
  fromEnum EvDisable = 8
  fromEnum EvDelete = 2
  fromEnum EvReceipt = 64
  fromEnum EvOneshot = 16
  fromEnum EvClear = 32
  fromEnum EvEof = 32768
  fromEnum EvError = 16384

  toEnum 1 = EvAdd
  toEnum 4 = EvEnable
  toEnum 8 = EvDisable
  toEnum 2 = EvDelete
  toEnum 64 = EvReceipt
  toEnum 16 = EvOneshot
  toEnum 32 = EvClear
  toEnum 32768 = EvEof
  toEnum 16384 = EvError
  toEnum unmatched = error ("Flag.toEnum: Cannot match " ++ show unmatched)

{-# LINE 109 "src/System/KQueue.chs" #-}

-- | The filter specific flags.
data FFlag = NoteDelete
           | NoteWrite
           | NoteExtend
           | NoteAttrib
           | NoteLink
           | NoteRename
           | NoteRevoke
           | NoteExit
           | NoteFork
           | NoteExec
           | NoteSignal
           | NoteReap
           deriving (Show,Eq)
instance Enum FFlag where
  fromEnum NoteDelete = 1
  fromEnum NoteWrite = 2
  fromEnum NoteExtend = 4
  fromEnum NoteAttrib = 8
  fromEnum NoteLink = 16
  fromEnum NoteRename = 32
  fromEnum NoteRevoke = 64
  fromEnum NoteExit = 2147483648
  fromEnum NoteFork = 1073741824
  fromEnum NoteExec = 536870912
  fromEnum NoteSignal = 134217728
  fromEnum NoteReap = 268435456

  toEnum 1 = NoteDelete
  toEnum 2 = NoteWrite
  toEnum 4 = NoteExtend
  toEnum 8 = NoteAttrib
  toEnum 16 = NoteLink
  toEnum 32 = NoteRename
  toEnum 64 = NoteRevoke
  toEnum 2147483648 = NoteExit
  toEnum 1073741824 = NoteFork
  toEnum 536870912 = NoteExec
  toEnum 134217728 = NoteSignal
  toEnum 268435456 = NoteReap
  toEnum unmatched = error ("FFlag.toEnum: Cannot match " ++ show unmatched)

{-# LINE 131 "src/System/KQueue.chs" #-}

-- | Convert a list of enumeration values to an integer by combining
-- them with bitwise 'or'.
enumToBitmask :: Enum a => [a] -> Int
enumToBitmask = foldl' (.|.) 0 . map fromEnum

-- | Convert an integer to a list of enumeration values by testing
-- each bit, and if set, convert it to an enumeration member.
bitmaskToEnum :: Enum a => Int -> [a]
bitmaskToEnum bm = mapMaybe maybeBit [0 .. bitSize bm - 1]
  where
    maybeBit b | testBit bm b = Just . toEnum . bit $ b
               | otherwise    = Nothing

instance Storable KEvent where
  sizeOf _ = 20
{-# LINE 151 "src/System/KQueue.chs" #-}
  alignment _ = 24
  peek e = KEvent <$>                                     ((\ptr -> do {peekByteOff ptr 0 ::IO CULong}) e)
                  <*> fmap (toEnum . fromIntegral)        ((\ptr -> do {peekByteOff ptr 4 ::IO CShort}) e)
                  <*> fmap (bitmaskToEnum . fromIntegral) ((\ptr -> do {peekByteOff ptr 6 ::IO CUShort}) e)
                  <*> fmap (bitmaskToEnum . fromIntegral) ((\ptr -> do {peekByteOff ptr 8 ::IO CUInt}) e)
                  <*>                                     ((\ptr -> do {peekByteOff ptr 12 ::IO CLong}) e)
                  <*>                                     ((\ptr -> do {peekByteOff ptr 16 ::IO (Ptr ())}) e)
  poke e ev =
    do (\ptr val -> do {pokeByteOff ptr 0 (val::CULong)}) e (ident                                   ev)
       (\ptr val -> do {pokeByteOff ptr 4 (val::CShort)}) e (fromIntegral . fromEnum . evfilter    $ ev)
       (\ptr val -> do {pokeByteOff ptr 6 (val::CUShort)}) e (fromIntegral . enumToBitmask . flags  $ ev)
       (\ptr val -> do {pokeByteOff ptr 8 (val::CUInt)}) e (fromIntegral . enumToBitmask . fflags $ ev)
       (\ptr val -> do {pokeByteOff ptr 12 (val::CLong)}) e (data_                                   ev)
       (\ptr val -> do {pokeByteOff ptr 16 (val::(Ptr ()))}) e (udata                                   ev)

newtype TimeSpec = TimeSpec NominalDiffTime
  deriving (Show, Eq)

-- TODO: waarom krijg ik geen CTime maar een CLong als seconds bij gebruik van #get/#set?
instance Storable TimeSpec where
  sizeOf _ = 8
{-# LINE 176 "src/System/KQueue.chs" #-}
  alignment _ = 8
  peek t =  mkTimeSpec
        <$> (\ptr -> peekByteOff ptr 0 :: IO CTime)  t
        <*> (\ptr -> do {peekByteOff ptr 4 ::IO CLong}) t
    where
      mkTimeSpec s ns = TimeSpec $ realToFrac s + realToFrac ns/1000000000
  poke t (TimeSpec dt) =
    do (\ptr val -> pokeByteOff ptr 0 (val :: CTime)) t (fromInteger s)
       (\ptr val -> do {pokeByteOff ptr 4 (val::CLong)}) t (floor . (* 1000000000) $ ns)
    where
      (s, ns) = properFraction dt

foreign import ccall "kevent" kevent_ :: CInt -> Ptr KEvent -> CInt -> Ptr KEvent -> CInt -> Ptr TimeSpec -> IO CInt

data KQueueException = KQueueException
  deriving (Show, Typeable)

instance Exception KQueueException

-- | Add events to monitor, or retrieve events from the kqueue. If an
-- error occurs, will throw a 'KQueueException' if there is no room in
-- the returned event list. Otherwise, will set 'EvError' on the event
-- and add it to the returned event list.
kevent ::  KQueue               -- ^ The kernel queue to operate on.
       -> [KEvent]              -- ^ The list of events to start monitoring, or changes to retrieve.
       -> Int                   -- ^ The maximum number of events to retrieve.
       -> Maybe NominalDiffTime -- ^ Timeout. When nothing, blocks until an event has occurred.
       -> IO [KEvent]           -- ^ A list of events that have occurred.
kevent (KQueue kq) changelist nevents mtimeout =
  withArray changelist $ \chArray ->
  allocaArray nevents  $ \evArray ->
  maybeWith with (TimeSpec <$> mtimeout) $ \timeout ->
    do ret <- kevent_ kq chArray (fromIntegral . length $ changelist) evArray (fromIntegral nevents) timeout
       case ret of
         -- Error while processing changelist, and no room in return array.
         -1 -> throwIO KQueueException
         -- Timeout.
         0  -> return []
         -- Returned n events. Can contain errors. The change that
         -- failed will be in the event list. EV_ERROR will be set on the
         -- event.
         n  -> peekArray (fromIntegral n) evArray

foreign import ccall safe "System/KQueue.chs.h kqueue"
  kqueue_ :: (IO CInt)