{-# LANGUAGE ForeignFunctionInterface #-}

module Wayland.Server.System where

#include <wayland-server.h>

import Foreign (FunPtr, Ptr, Storable(..), Int32)
import Foreign.C (CString, CInt(..), CSize)
import Data.Word (Word32)

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 WLFixed = WLFixed #{type wl_fixed_t}
  deriving (Show)

data WLArray
  = WLArray { arrSize  :: CSize
            , arrAlloc :: CSize
            , arrData  :: Ptr ()
            }
  deriving (Show)

data WLArgument = WLArgument
  deriving (Show)

newtype WLDisplay     = WLDisplay     (Ptr WLDisplay)     deriving (Show)
newtype WLEventLoop   = WLEventLoop   (Ptr WLEventLoop)   deriving (Show)
newtype WLEventSource = WLEventSource (Ptr WLEventSource) deriving (Show)
newtype WLGlobal      = WLGlobal      (Ptr WLGlobal)      deriving (Show)
newtype WLClient      = WLClient      (Ptr WLClient)      deriving (Show)
newtype WLResource    = WLResource    (Ptr WLResource)    deriving (Show)

type WLEventLoopSignalFunc = CInt -> Ptr () -> IO CInt
type WLGlobalBindFunc      = WLClient -> Ptr () -> Word32 -> Word32 -> IO ()
type WLDispatcherFunc      = Ptr () -> WLResource -> Word32 -> Ptr WLMessage -> Ptr WLArgument -> IO CInt
type WLResourceDestroyFunc = WLResource -> IO ()

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

foreign import ccall "wrapper"
  wrapWLGlobalBindFunc :: WLGlobalBindFunc -> IO (FunPtr WLGlobalBindFunc)

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

foreign import ccall "wl_global_create"
  wlGlobalCreate :: WLDisplay -> Ptr WLInterface -> CInt -> Ptr () -> FunPtr WLGlobalBindFunc -> IO WLGlobal

foreign import ccall "wl_resource_create"
  wlResourceCreate :: WLClient -> Ptr WLInterface -> CInt -> Word32 -> IO WLResource

foreign import ccall "wl_resource_set_dispatcher"
  wlResourceSetDispatcher :: WLResource -> FunPtr WLDispatcherFunc -> Ptr () -> Ptr () -> FunPtr WLResourceDestroyFunc -> IO ()

wlArgumentGetInt :: Ptr WLArgument -> IO Int32
wlArgumentGetInt = #{peek union wl_argument, i}

wlArgumentGetUInt :: Ptr WLArgument -> IO Word32
wlArgumentGetUInt = #{peek union wl_argument, u}

wlArgumentGetFixed :: Ptr WLArgument -> IO WLFixed
wlArgumentGetFixed = #{peek union wl_argument, f}

wlArgumentGetString :: Ptr WLArgument -> IO CString
wlArgumentGetString = #{peek union wl_argument, s}

wlArgumentGetObject :: Ptr WLArgument -> IO WLResource
wlArgumentGetObject = #{peek union wl_argument, o}

wlArgumentGetNewID :: Ptr WLArgument -> IO Word32
wlArgumentGetNewID = #{peek union wl_argument, n}

wlArgumentGetArray :: Ptr WLArgument -> IO (Ptr WLArray)
wlArgumentGetArray = #{peek union wl_argument, a}

wlArgumentGetFD :: Ptr WLArgument -> IO Int32
wlArgumentGetFD = #{peek union wl_argument, h}

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 ()