{-# LANGUAGE ForeignFunctionInterface #-}

module Wayland.Server.System where

#include <wayland-server.h>

import Foreign (FunPtr, Ptr, Storable(..))
import Foreign.C (CString, CInt(..))

data WLMessage
  = WLMessage { msgName      :: CString
              , msgSignature :: CString
              , msgTypes     :: Ptr (Ptr WLInterface)
              }
  deriving (Show)

data WLInterface
  = WLInterface { ifName        :: CString
                , ifVersion     :: CInt
                , ifMethodCount :: CInt
                , ifMethods     :: Ptr WLMessage
                , ifEventCount  :: CInt
                , ifEvents      :: Ptr WLMessage
                }
  deriving (Show)

newtype WLDisplay     = WLDisplay     (Ptr WLDisplay)
newtype WLEventLoop   = WLEventLoop   (Ptr WLEventLoop)
newtype WLEventSource = WLEventSource (Ptr WLEventSource)

type WLEventLoopSignalFunc = CInt -> Ptr () -> IO CInt

foreign import ccall "wrapper"
  wrapWLEventLoopSignalFunc :: WLEventLoopSignalFunc -> IO (FunPtr WLEventLoopSignalFunc)

foreign import ccall "wl_display_create"
  wlDisplayCreate :: IO WLDisplay

foreign import ccall "wl_display_destroy"
  wlDisplayDestroy :: WLDisplay -> IO ()

foreign import ccall "wl_display_add_socket_auto"
  wlDisplayAddSocketAuto :: WLDisplay -> IO CString

foreign import ccall "wl_display_run"
  wlDisplayRun :: WLDisplay -> IO ()

foreign import ccall "wl_display_terminate"
  wlDisplayTerminate :: WLDisplay -> IO ()

foreign import ccall "wl_display_get_event_loop"
  wlDisplayGetEventLoop :: WLDisplay -> IO WLEventLoop

foreign import ccall "wl_event_loop_add_signal"
  wlEventLoopAddSignal :: WLEventLoop -> CInt -> FunPtr WLEventLoopSignalFunc -> Ptr () -> IO WLEventSource

instance Storable WLMessage where
  sizeOf    _ = #{size struct wl_message}
  alignment _ = #{alignment struct wl_message}
  peek p = do
    name      <- #{peek struct wl_message, name}      p
    signature <- #{peek struct wl_message, signature} p
    types     <- #{peek struct wl_message, types}     p
    return $ WLMessage { msgName      = name
                       , msgSignature = signature
                       , msgTypes     = types
                       }
  poke p m = do
    #{poke struct wl_message, name}      p $ msgName      m
    #{poke struct wl_message, signature} p $ msgSignature m
    #{poke struct wl_message, types}     p $ msgTypes     m
    return ()

instance Storable WLInterface where
  sizeOf    _ = #{size struct wl_interface}
  alignment _ = #{alignment struct wl_interface}
  peek p = do
    name        <- #{peek struct wl_interface, name}         p
    version     <- #{peek struct wl_interface, version}      p
    methodCount <- #{peek struct wl_interface, method_count} p
    methods     <- #{peek struct wl_interface, methods}      p
    eventCount  <- #{peek struct wl_interface, event_count}  p
    events      <- #{peek struct wl_interface, events}       p
    return $ WLInterface { ifName        = name
                         , ifVersion     = version
                         , ifMethodCount = methodCount
                         , ifMethods     = methods
                         , ifEventCount  = eventCount
                         , ifEvents      = events
                         }
  poke p m = do
    #{poke struct wl_interface, name}         p $ ifName        m
    #{poke struct wl_interface, version}      p $ ifVersion     m
    #{poke struct wl_interface, method_count} p $ ifMethodCount m
    #{poke struct wl_interface, methods}      p $ ifMethods     m
    #{poke struct wl_interface, event_count}  p $ ifEventCount  m
    #{poke struct wl_interface, events}       p $ ifEvents      m
    return ()