path: root/wayland/Wayland/Server/System.hsc

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- |
-- Module     : Wayland.Server.System
-- Description: Bindings for the system-provided libwayland library.
--
-- libwayland is used to handle socket creation, implementing the protocol, and the event loop. We do not use the
-- interfaces or bindings provided by it but only its primitives like wl_resource in combination with our own code
-- generator which generates the interfaces and (de-)marshals all arguments and opcodes. This is done to keep the amount
-- of C interop small.

module Wayland.Server.System where

#include <wayland-server.h>

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

-- * Callback Types

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)

-- * Primitive Types

-- ** wl_message

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

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

-- ** wl_interface

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

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

-- ** wl_fixed

newtype WLFixed = WLFixed #{type wl_fixed_t}
  deriving (Show)

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

wlFixedToFloat :: WLFixed -> Float
wlFixedToFloat (WLFixed v) = (fromIntegral v) / 256

-- ** wl_array

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

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

-- ** wl_argument

-- Accessed through the wlArgumentPeek* and wlArgumentPoke* methods as the actual data type is unknown just from looking
-- at the union.
data WLArgument = WLArgument
  deriving (Show)

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

wlArgumentPeekInt    :: Ptr WLArgument -> IO Int32
wlArgumentPeekInt    = #{peek union wl_argument, i}
wlArgumentPeekUInt   :: Ptr WLArgument -> IO Word32
wlArgumentPeekUInt   = #{peek union wl_argument, u}
wlArgumentPeekFixed  :: Ptr WLArgument -> IO WLFixed
wlArgumentPeekFixed  = #{peek union wl_argument, f}
wlArgumentPeekString :: Ptr WLArgument -> IO CString
wlArgumentPeekString = #{peek union wl_argument, s}
wlArgumentPeekObject :: Ptr WLArgument -> IO WLResource
wlArgumentPeekObject = #{peek union wl_argument, o}
wlArgumentPeekNewID  :: Ptr WLArgument -> IO Word32
wlArgumentPeekNewID  = #{peek union wl_argument, n}
wlArgumentPeekArray  :: Ptr WLArgument -> IO (Ptr WLArray)
wlArgumentPeekArray  = #{peek union wl_argument, a}
wlArgumentPeekFD     :: Ptr WLArgument -> IO Int32
wlArgumentPeekFD     = #{peek union wl_argument, h}

wlArgumentPokeInt    :: Ptr WLArgument -> Int32 -> IO ()
wlArgumentPokeInt    = #{poke union wl_argument, i}
wlArgumentPokeUInt   :: Ptr WLArgument -> Word32 -> IO ()
wlArgumentPokeUInt   = #{poke union wl_argument, u}
wlArgumentPokeFixed  :: Ptr WLArgument -> WLFixed -> IO ()
wlArgumentPokeFixed  = #{poke union wl_argument, f}
wlArgumentPokeString :: Ptr WLArgument -> CString -> IO ()
wlArgumentPokeString = #{poke union wl_argument, s}
wlArgumentPokeObject :: Ptr WLArgument -> WLResource -> IO ()
wlArgumentPokeObject = #{poke union wl_argument, o}
wlArgumentPokeNewID  :: Ptr WLArgument -> Word32 -> IO ()
wlArgumentPokeNewID  = #{poke union wl_argument, n}
wlArgumentPokeArray  :: Ptr WLArgument -> Ptr WLArray -> IO ()
wlArgumentPokeArray  = #{poke union wl_argument, a}
wlArgumentPokeFD     :: Ptr WLArgument -> Int32 -> IO ()
wlArgumentPokeFD     = #{poke union wl_argument, h}

-- * Opaque Types

-- ** wl_display

newtype WLDisplay = WLDisplay (Ptr WLDisplay)
  deriving (Show, Eq, Storable)

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

-- ** wl_event_loop

newtype WLEventLoop = WLEventLoop (Ptr WLEventLoop)
  deriving (Show, Eq, Storable)

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

-- ** wl_event_source

newtype WLEventSource = WLEventSource (Ptr WLEventSource)
  deriving (Show, Eq, Storable)

-- ** wl_global

newtype WLGlobal = WLGlobal (Ptr WLGlobal)
  deriving (Show, Eq, Storable)

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

-- ** wl_client

newtype WLClient = WLClient (Ptr WLClient)
  deriving (Show, Eq, Storable)

-- ** wl_resource

newtype WLResource = WLResource (Ptr WLResource)
  deriving (Show, Eq, Storable)

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