{-# LANGUAGE ForeignFunctionInterface #-}

module Wayland.Server.System where

#include <wayland-server.h>

import Foreign (FunPtr, Ptr, Storable(..), Int32, castPtr)
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 "wrapper"
  wrapWLDispatcherFunc :: WLDispatcherFunc -> IO (FunPtr WLDispatcherFunc)

foreign import ccall "wrapper"
  wrapWLResourceDestroyFunc :: WLResourceDestroyFunc -> IO (FunPtr WLResourceDestroyFunc)

foreign import ccall "wl_display_create"
  wlDisplayCreate :: IO WLDisplay

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

foreign import ccall "wl_display_flush_clients"
  wlDisplayFlushClients :: 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 ()

foreign import ccall "wl_resource_get_user_data"
  wlResourceGetUserData :: WLResource -> IO (Ptr ())

foreign import ccall "wl_resource_post_event_array"
  wlResourcePostEventArray :: WLResource -> Word32 -> Ptr WLArgument -> IO ()

foreign import ccall "wl_resource_destroy"
  wlResourceDestroy :: WLResource -> 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 (Ptr ())
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}

wlArgumentSetInt :: Int32 -> Ptr WLArgument -> IO ()
wlArgumentSetInt v p = #{poke union wl_argument, i} p v

wlArgumentSetUInt :: Word32 -> Ptr WLArgument -> IO ()
wlArgumentSetUInt v p = #{poke union wl_argument, u} p v

wlArgumentSetFixed :: WLFixed -> Ptr WLArgument -> IO ()
wlArgumentSetFixed v p = #{poke union wl_argument, f} p v

wlArgumentSetString :: CString -> Ptr WLArgument -> IO ()
wlArgumentSetString v p = #{poke union wl_argument, s} p v

wlArgumentSetObject :: Ptr () -> Ptr WLArgument -> IO ()
wlArgumentSetObject v p = #{poke union wl_argument, o} p v

wlArgumentSetNewID :: Word32 -> Ptr WLArgument -> IO ()
wlArgumentSetNewID v p = #{poke union wl_argument, n} p v

wlArgumentSetArray :: Ptr WLArray -> Ptr WLArgument -> IO ()
wlArgumentSetArray v p = #{poke union wl_argument, a} p v

wlArgumentSetFD :: Int32 -> Ptr WLArgument -> IO ()
wlArgumentSetFD v p = #{poke union wl_argument, h} p v

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

instance Storable WLArray where
  sizeOf    _ = #{size struct wl_array}
  alignment _ = #{alignment struct wl_array}
  peek p = do
    aSize  <- #{peek struct wl_array, size}  p
    aAlloc <- #{peek struct wl_array, alloc} p
    aData  <- #{peek struct wl_array, data}  p
    return $ WLArray { arrSize  = aSize
                     , arrAlloc = aAlloc
                     , arrData  = aData
                     }
  poke p m = do
    #{poke struct wl_array, size}  p $ arrSize  m
    #{poke struct wl_array, alloc} p $ arrAlloc m
    #{poke struct wl_array, data}  p $ arrData  m
    return ()

instance Storable WLFixed where
  sizeOf    _             = sizeOf    (undefined :: #{type wl_fixed_t})
  alignment _             = alignment (undefined :: #{type wl_fixed_t})
  peek      p             = WLFixed <$> peek (castPtr p)
  poke      p (WLFixed v) = poke (castPtr p) v

instance Storable WLArgument where
  sizeOf    _   = #{size union wl_argument}
  alignment _   = #{alignment union wl_argument}
  peek      _   = pure WLArgument
  poke      _ _ = pure ()