-- GENERATED by C->Haskell Compiler, version 0.28.6 Switcheroo, 25 November 2017 (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 qualified Foreign.C.Types as C2HSImp
import qualified Foreign.Ptr as C2HSImp
import qualified Foreign.Storable as C2HSImp






import Control.Exception   ( Exception, bracket_, throwIO )
import Data.List           ( foldl' )
import Data.Maybe          ( mapMaybe )
import Data.Time.Clock     ( NominalDiffTime )
import Data.Typeable       ( Typeable )
import Foreign             ( (.|.)
                           , Ptr
                           , Storable (..)
                           , allocaArray
                           , bit
                           , finiteBitSize
                           , maybeWith
                           , testBit
                           , peekArray
                           , with
                           , withArray
                           )

import Foreign.C           ( CInt (..) )
import Foreign.C           ( CLong
                           , CTime
                           , CULong
                           )
import System.Posix.Signals ( blockSignals
                            , reservedSignals
                            , unblockSignals
                            )

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

-- | Create a new KQueue.
kqueue :: IO KQueue
kqueue = KQueue <$> kqueue_
{-# LINE 71 "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 = EvfiltTimer
            | EvfiltSignal
            | EvfiltProc
            | EvfiltVnode
            | EvfiltAio
            | EvfiltWrite
            | EvfiltRead
  deriving (Show,Eq)
instance Enum Filter where
  succ EvfiltTimer = EvfiltSignal
  succ EvfiltSignal = EvfiltProc
  succ EvfiltProc = EvfiltVnode
  succ EvfiltVnode = EvfiltAio
  succ EvfiltAio = EvfiltWrite
  succ EvfiltWrite = EvfiltRead
  succ EvfiltRead = error "Filter.succ: EvfiltRead has no successor"

  pred EvfiltSignal = EvfiltTimer
  pred EvfiltProc = EvfiltSignal
  pred EvfiltVnode = EvfiltProc
  pred EvfiltAio = EvfiltVnode
  pred EvfiltWrite = EvfiltAio
  pred EvfiltRead = EvfiltWrite
  pred EvfiltTimer = error "Filter.pred: EvfiltTimer has no predecessor"

  enumFromTo from to = go from
    where
      end = fromEnum to
      go v = case compare (fromEnum v) end of
                 LT -> v : go (succ v)
                 EQ -> [v]
                 GT -> []

  enumFrom from = enumFromTo from EvfiltRead

  fromEnum EvfiltTimer = (-7)
  fromEnum EvfiltSignal = (-6)
  fromEnum EvfiltProc = (-5)
  fromEnum EvfiltVnode = (-4)
  fromEnum EvfiltAio = (-3)
  fromEnum EvfiltWrite = (-2)
  fromEnum EvfiltRead = (-1)

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

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


-- | The actions to perform on the event.
data Flag = EvAdd
          | EvDelete
          | EvEnable
          | EvDisable
          | EvOneshot
          | EvClear
          | EvReceipt
          | EvError
          | EvEof
  deriving (Show,Eq)
instance Enum Flag where
  succ EvAdd = EvDelete
  succ EvDelete = EvEnable
  succ EvEnable = EvDisable
  succ EvDisable = EvOneshot
  succ EvOneshot = EvClear
  succ EvClear = EvReceipt
  succ EvReceipt = EvError
  succ EvError = EvEof
  succ EvEof = error "Flag.succ: EvEof has no successor"

  pred EvDelete = EvAdd
  pred EvEnable = EvDelete
  pred EvDisable = EvEnable
  pred EvOneshot = EvDisable
  pred EvClear = EvOneshot
  pred EvReceipt = EvClear
  pred EvError = EvReceipt
  pred EvEof = EvError
  pred EvAdd = error "Flag.pred: EvAdd has no predecessor"

  enumFromTo from to = go from
    where
      end = fromEnum to
      go v = case compare (fromEnum v) end of
                 LT -> v : go (succ v)
                 EQ -> [v]
                 GT -> []

  enumFrom from = enumFromTo from EvEof

  fromEnum EvAdd = 1
  fromEnum EvDelete = 2
  fromEnum EvEnable = 4
  fromEnum EvDisable = 8
  fromEnum EvOneshot = 16
  fromEnum EvClear = 32
  fromEnum EvReceipt = 64
  fromEnum EvError = 16384
  fromEnum EvEof = 32768

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

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


-- | The filter specific flags.
data FFlag = NoteDelete
           | NoteWrite
           | NoteExtend
           | NoteAttrib
           | NoteLink
           | NoteRename
           | NoteRevoke
           | NoteSignal
           | NoteExec
           | NoteFork
           | NoteExit
  deriving (Show,Eq)
instance Enum FFlag where
  succ NoteDelete = NoteWrite
  succ NoteWrite = NoteExtend
  succ NoteExtend = NoteAttrib
  succ NoteAttrib = NoteLink
  succ NoteLink = NoteRename
  succ NoteRename = NoteRevoke
  succ NoteRevoke = NoteSignal
  succ NoteSignal = NoteExec
  succ NoteExec = NoteFork
  succ NoteFork = NoteExit
  succ NoteExit = error "FFlag.succ: NoteExit has no successor"

  pred NoteWrite = NoteDelete
  pred NoteExtend = NoteWrite
  pred NoteAttrib = NoteExtend
  pred NoteLink = NoteAttrib
  pred NoteRename = NoteLink
  pred NoteRevoke = NoteRename
  pred NoteSignal = NoteRevoke
  pred NoteExec = NoteSignal
  pred NoteFork = NoteExec
  pred NoteExit = NoteFork
  pred NoteDelete = error "FFlag.pred: NoteDelete has no predecessor"

  enumFromTo from to = go from
    where
      end = fromEnum to
      go v = case compare (fromEnum v) end of
                 LT -> v : go (succ v)
                 EQ -> [v]
                 GT -> []

  enumFrom from = enumFromTo from NoteExit

  fromEnum NoteDelete = 1
  fromEnum NoteWrite = 2
  fromEnum NoteExtend = 4
  fromEnum NoteAttrib = 8
  fromEnum NoteLink = 16
  fromEnum NoteRename = 32
  fromEnum NoteRevoke = 64
  fromEnum NoteSignal = 134217728
  fromEnum NoteExec = 536870912
  fromEnum NoteFork = 1073741824
  fromEnum NoteExit = 2147483648

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

{-# LINE 138 "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 .. finiteBitSize bm - 1]
  where
    maybeBit b | testBit bm b = Just . toEnum . bit $ b
               | otherwise    = Nothing

instance Storable KEvent where
  sizeOf _ = 32
{-# LINE 157 "src/System/KQueue.chs" #-}

  alignment _ = 24
  peek e = KEvent <$>                                     ((\ptr -> do {C2HSImp.peekByteOff ptr 0 :: IO C2HSImp.CULong}) e)
                  <*> fmap (toEnum . fromIntegral)        ((\ptr -> do {C2HSImp.peekByteOff ptr 8 :: IO C2HSImp.CShort}) e)
                  <*> fmap (bitmaskToEnum . fromIntegral) ((\ptr -> do {C2HSImp.peekByteOff ptr 10 :: IO C2HSImp.CUShort}) e)
                  <*> fmap (bitmaskToEnum . fromIntegral) ((\ptr -> do {C2HSImp.peekByteOff ptr 12 :: IO C2HSImp.CUInt}) e)
                  <*>                                     ((\ptr -> do {C2HSImp.peekByteOff ptr 16 :: IO C2HSImp.CLong}) e)
                  <*>                                     ((\ptr -> do {C2HSImp.peekByteOff ptr 24 :: IO (C2HSImp.Ptr ())}) e)
  poke e ev =
    do (\ptr val -> do {C2HSImp.pokeByteOff ptr 0 (val :: C2HSImp.CULong)}) e (ident                                   ev)
       (\ptr val -> do {C2HSImp.pokeByteOff ptr 8 (val :: C2HSImp.CShort)}) e (fromIntegral . fromEnum . evfilter    $ ev)
       (\ptr val -> do {C2HSImp.pokeByteOff ptr 10 (val :: C2HSImp.CUShort)}) e (fromIntegral . enumToBitmask . flags  $ ev)
       (\ptr val -> do {C2HSImp.pokeByteOff ptr 12 (val :: C2HSImp.CUInt)}) e (fromIntegral . enumToBitmask . fflags $ ev)
       (\ptr val -> do {C2HSImp.pokeByteOff ptr 16 (val :: C2HSImp.CLong)}) e (data_                                   ev)
       (\ptr val -> do {C2HSImp.pokeByteOff ptr 24 (val :: (C2HSImp.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 _ = 16
{-# LINE 181 "src/System/KQueue.chs" #-}

  alignment _ = 8
  peek t =  mkTimeSpec
        <$> (\ptr -> peekByteOff ptr 0 :: IO CTime)  t
        <*> (\ptr -> do {C2HSImp.peekByteOff ptr 8 :: IO C2HSImp.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 {C2HSImp.pokeByteOff ptr 8 (val :: C2HSImp.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 <- bracket_
      (blockSignals reservedSignals)
      (unblockSignals reservedSignals)
      (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 C2HSImp.CInt)