start working on c bindings for libwayland

1 files changed, 65 insertions, 15 deletions

diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
index 9162d5e..0b0b6ea 100644
--- a/wayland/Wayland/Server.hs
+++ b/wayland/Wayland/Server.hs
@@ -10,7 +10,11 @@ module Wayland.Server
   , ObjectID
   , Global
   , DisplayM(..)
-  , Resource(..)
+  , ResourceClass(..)
+  , InterfaceDesc(..)
+  , MessageDesc(..)
+  , ArgumentDesc(..)
+  , Nullability(..)
   , fromRequest
   , withDisplay
   , bindSocket
@@ -22,22 +26,58 @@ module Wayland.Server
   , unregisterGlobal
   ) where
 
-import Data.Typeable (Typeable, cast)
+import Data.Typeable (Typeable, Proxy, cast)
 import Data.Kind (Type)
-import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..))
+import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT, gets)
 import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
+import Wayland.Server.System
+import Control.Monad.Trans (MonadTrans(..))
+import Foreign.C (peekCString)
 
 data DisplayState
+  = DisplayState { display :: WLDisplay
+                 }
 
-data Global
+data Global = Global
 
 newtype ObjectID = ObjectID String
   deriving (Show, Eq, Ord)
 
-class Resource r where
+data Nullability
+  = AllowNull
+  | NotNull
+
+data ArgumentDesc
+  = ArgumentInt
+  | ArgumentUInt
+  | ArgumentFixed
+  | ArgumentString !Nullability
+  | ArgumentObject !Nullability
+  | ArgumentNewID
+  | ArgumentArray
+  | ArgumentFD
+
+data MessageDesc
+  = MessageDesc { msgName              :: !String
+                , msgSignature         :: ![ArgumentDesc]
+                , msgSince             :: !Int
+                , msgIsDestructor      :: !Bool
+                , msgCreatedInterface  :: !(Maybe InterfaceDesc)
+                , msgArgumentInterface :: ![InterfaceDesc]
+                }
+
+data InterfaceDesc
+  = InterfaceDesc { ifName     :: !String
+                  , ifVersion  :: !Int
+                  , ifRequests :: ![MessageDesc]
+                  , ifEvents   :: ![MessageDesc]
+                  }
+
+class ResourceClass r where
   type ResourceRequest r :: Type
   type ResourceEvent   r :: Type
-  objectID :: r -> ObjectID
+  objectID  :: r -> ObjectID
+  interface :: Proxy r -> InterfaceDesc
 
 data Request = forall a. Typeable a => Request a
 
@@ -52,26 +92,36 @@ instance Zoom (DisplayM s) (DisplayM t) s t where
 fromRequest :: Typeable a => Request -> Maybe a
 fromRequest (Request x) = cast x
 
-withDisplay :: s -> DisplayM s a -> IO (s, a)
-withDisplay _ _ = undefined
+withDisplay :: s -> DisplayM s a -> IO (a, s)
+withDisplay initialState f = do
+  disp <- wlDisplayCreate
+  let dispState = DisplayState { display = disp }
+  (res, _) <-runStateT (runStateT (runDisplayM f) initialState) dispState
+  wlDisplayDestroy disp
+  return res
 
 bindSocket :: DisplayM s String
-bindSocket = undefined
+bindSocket = do
+  disp <- DisplayM $ lift $ gets display
+  name <- liftIO $ wlDisplayAddSocketAuto disp
+  liftIO $ peekCString name
 
 processRequests :: (Request -> DisplayM s ()) -> DisplayM s ()
-processRequests _ = undefined
+processRequests _ = do
+  disp <- DisplayM $ lift $ gets display
+  liftIO $ wlDisplayRun disp
 
-sendEvent :: Resource r => r -> ResourceEvent r -> DisplayM s ()
+sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
 sendEvent _ _ = undefined
 
 flushEvents :: DisplayM s ()
 flushEvents = undefined
 
-destroyResource :: Resource r => r -> DisplayM s ()
+destroyResource :: ResourceClass r => r -> DisplayM s ()
 destroyResource _ = undefined
 
-registerGlobal :: Resource r => Typeable req => (r -> req) -> DisplayM s Global
-registerGlobal _ = undefined
+registerGlobal :: ResourceClass r => Typeable req => (r -> req) -> DisplayM s Global
+registerGlobal _ = pure Global
 
 unregisterGlobal :: Global -> DisplayM s ()
-unregisterGlobal _ = undefined
+unregisterGlobal _ = pure ()