wip refactoring

9 files changed, 940 insertions, 461 deletions

diff --git a/highway/Main.hs b/highway/Main.hs
index a13fa0e..2e8161d 100644
--- a/highway/Main.hs
+++ b/highway/Main.hs
@@ -20,22 +20,18 @@ geometry = WLOutput.Geometry { WLOutput.x              = 0
                              , WLOutput.transform      = WLOutput.TransformNormal
                              }
 
-data BindRequest
-  = BindOutput   WLOutput.Handle
-  | UnbindOutput WLOutput.Handle
+data CustomRequest
+  = ReqBindOutput    (NewObject WLOutput.WLOutput)
+  | ReqDestroyOutput WLOutput.WLOutput
+  | ReqSIGINT
   deriving (Typeable, Show)
 
-data SignalRequest
-  = ReqSIGINT
-  deriving (Typeable, Show)
-
-instance RequestClass SignalRequest
-instance RequestClass BindRequest
+instance RequestClass CustomRequest
 
 data Output = Output
   deriving (Show)
 
-data State = State { _outputs          :: M.Map WLOutput.Handle Output
+data State = State { _outputs          :: M.Map WLOutput.WLOutput Output
                    , _interruptedCount :: Int
                    }
   deriving (Show)
@@ -44,13 +40,14 @@ makeLenses ''State
 
 handleRequest :: Request -> DisplayM State ()
 handleRequest r
-  | Just (WLOutput.ReqRelease o) <- fromRequest r = destroyResource o
-  | Just (BindOutput o)          <- fromRequest r = do outs <- outputs <%= M.insert o Output
-                                                       sendEvent o $ WLOutput.EvGeometry geometry
-                                                       sendEvent o $ WLOutput.EvDone
+  | Just (WLOutput.ReqRelease o) <- fromRequest r = destroyObject o
+  | Just (ReqBindOutput o)       <- fromRequest r = do output <- createObject o ReqDestroyOutput
+                                                       outs <- outputs <%= M.insert output Output
+                                                       sendEvent output $ WLOutput.EvGeometry geometry
+                                                       sendEvent output $ WLOutput.EvDone
                                                        liftIO $ putStrLn $ "Created output, outputs: " ++ show outs
                                                        flushEvents
-  | Just (UnbindOutput o)        <- fromRequest r = outputs %= M.delete o
+  | Just (ReqDestroyOutput o)    <- fromRequest r = outputs %= M.delete o
   | Just ReqSIGINT               <- fromRequest r = do c <- interruptedCount <%= (+1)
                                                        liftIO $ putStrLn $ "Received SIGINT " ++ show c ++ "/3"
                                                        when (c >= 3) requestTermination
@@ -61,6 +58,6 @@ main = void $ withDisplay (State M.empty 0) $ do
   socket <- bindSocket
   liftIO $ putStrLn $ "Listening on socket: " ++ socket
   _ <- registerSignalEvent ReqSIGINT 2
-  output <- registerGlobal BindOutput UnbindOutput 4
+  output <- registerGlobal ReqBindOutput 4
   processRequests handleRequest
   unregisterGlobal output
diff --git a/protocols/Wayland/Protocols/Core/WLOutput.hs b/protocols/Wayland/Protocols/Core/WLOutput.hs
index d6adda2..3c4a8f5 100644
--- a/protocols/Wayland/Protocols/Core/WLOutput.hs
+++ b/protocols/Wayland/Protocols/Core/WLOutput.hs
@@ -9,26 +9,26 @@ module Wayland.Protocols.Core.WLOutput
   , Geometry(..)
   , Request(..)
   , Event(..)
-  , Handle(..)
+  , WLOutput(..)
   ) where
 
 import Data.Data (Typeable)
-import Wayland.Server (ResourceClass(..), RequestClass, InterfaceDesc(..), MessageDesc(..), ArgumentDesc(..), Nullability(..), ObjectID, EventClass, marshalInt, marshalString, marshalUInt)
+import Wayland.Server (Object(..), RequestClass, InterfaceDesc(..), MessageDesc(..), ArgumentDesc(..), Nullability(..), AnyObject, EventClass, marshalInt, marshalString, marshalUInt)
 import Data.Hashable (Hashable(..))
 
-newtype Handle = Handle ObjectID
+newtype WLOutput = WLOutput AnyObject
   deriving (Show, Eq, Ord, Hashable)
 
 reqRelease :: MessageDesc
 reqRelease = MessageDesc { msgName         = "release"
-                         , msgSignature    = []
+                         , msgArguments    = []
                          , msgSince        = 3
                          , msgIsDestructor = True
                          }
 
 evGeometry :: MessageDesc
 evGeometry = MessageDesc { msgName         = "geometry"
-                         , msgSignature    = [ ArgumentInt
+                         , msgArguments    = [ ArgumentInt
                                              , ArgumentInt
                                              , ArgumentInt
                                              , ArgumentInt
@@ -43,7 +43,7 @@ evGeometry = MessageDesc { msgName         = "geometry"
 
 evMode :: MessageDesc
 evMode = MessageDesc { msgName         = "mode"
-                     , msgSignature    = [ ArgumentUInt
+                     , msgArguments    = [ ArgumentUInt
                                          , ArgumentInt
                                          , ArgumentInt
                                          , ArgumentInt
@@ -54,51 +54,52 @@ evMode = MessageDesc { msgName         = "mode"
 
 evDone :: MessageDesc
 evDone = MessageDesc { msgName         = "done"
-                     , msgSignature    = []
+                     , msgArguments    = []
                      , msgSince        = 2
                      , msgIsDestructor = False
                      }
 
 evScale :: MessageDesc
 evScale = MessageDesc { msgName         = "scale"
-                      , msgSignature    = [ ArgumentInt ]
+                      , msgArguments    = [ ArgumentInt ]
                       , msgSince        = 2
                       , msgIsDestructor = False
                       }
 
 evName :: MessageDesc
 evName = MessageDesc { msgName         = "name"
-                     , msgSignature    = [ ArgumentString NotNull ]
+                     , msgArguments    = [ ArgumentString NotNull ]
                      , msgSince        = 4
                      , msgIsDestructor = False
                      }
 
 evDescription :: MessageDesc
 evDescription = MessageDesc { msgName         = "description"
-                            , msgSignature    = [ ArgumentString NotNull ]
+                            , msgArguments    = [ ArgumentString NotNull ]
                             , msgSince        = 4
                             , msgIsDestructor = False
                             }
 
-instance ResourceClass Handle where
-  type ResourceEvent   Handle = Event
-  type ResourceRequest Handle = Request
-  objectID (Handle h) = h
-  fromID = Handle
-  interface _ = InterfaceDesc { ifName     = "wl_output"
-                              , ifVersion  = 4
-                              , ifRequests = [ reqRelease ]
-                              , ifEvents   = [ evGeometry
-                                             , evMode
-                                             , evDone
-                                             , evScale
-                                             , evName
-                                             , evDescription ]
-                              }
+instance Object WLOutput where
+  type ObjectEvent   WLOutput = Event
+  type ObjectRequest WLOutput = Request
+  toAny (WLOutput o) = o
+  fromAny = WLOutput
+  describeInterface _ = InterfaceDesc { ifName     = "wl_output"
+                                      , ifVersion  = 4
+                                      , ifRequests = [ reqRelease ]
+                                      , ifEvents   = [ evGeometry
+                                                     , evMode
+                                                     , evDone
+                                                     , evScale
+                                                     , evName
+                                                     , evDescription
+                                                     ]
+                                      }
 
   demarshalRequest r 0 = do
     pure (ReqRelease r)
-  demarshalRequest _ _ = fail "Unknown opcode."
+  demarshalRequest _ _ = error "Unknown opcode."
 
   marshalEvent _ (EvGeometry p) = do
     marshalInt    (x p)
@@ -187,7 +188,7 @@ data Geometry
   deriving (Show)
 
 data Request
-  = ReqRelease Handle
+  = ReqRelease WLOutput
   deriving (Typeable, Show)
 
 instance RequestClass Request where
diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
index 30300de..61486b0 100644
--- a/wayland/Wayland/Server.hs
+++ b/wayland/Wayland/Server.hs
@@ -1,426 +1,44 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
+-- |
+-- Module     : Wayland.Server
+-- Description: Low-level API for implementing the Wayland protocol.
 
 module Wayland.Server
-  ( Request(..)
-  , ObjectID
-  , Global
-  , ArgumentMarshaller(..)
-  , ArgumentDemarshaller(..)
-  , DisplayM(..)
-  , ResourceClass(..)
-  , EventClass
-  , RequestClass
-  , InterfaceDesc(..)
-  , MessageDesc(..)
-  , ArgumentDesc(..)
-  , Nullability(..)
-  , fromRequest
+  ( -- * The Display Monad
+    DisplayM
   , withDisplay
   , bindSocket
+  ,  -- * Processing Requests
+    Request(..)
+  , RequestHandler
+  , fromRequest
   , processRequests
-  , flushEvents
-  , sendEvent
-  , destroyResource
+  , requestTermination
+  , -- * Managing Objects
+    Global
   , registerGlobal
   , unregisterGlobal
+  , createObject
+  , destroyObject
+  , sendEvent
+  , flushEvents
+  , -- * Event Sources
+    EventSource
   , registerSignalEvent
-  , requestTermination
+  , -- * Interface Descriptions
+    InterfaceDesc(..)
+  , MessageDesc(..)
+  , ArgumentDesc(..)
+  , Nullability(..)
+  , -- * Object Types
+    Object(..)
+  , AnyObject
+  , NewObject
+  , RequestClass
+  , EventClass
+  , ArgumentMarshaller(..)
+  , ArgumentDemarshaller(..)
   ) where
 
-import Data.Typeable (Typeable, Proxy(..), cast, TypeRep, typeRep)
-import Data.Kind (Type)
-import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT)
-import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
-import Lens.Micro.TH (makeLenses)
-import Lens.Micro.Mtl ((%=), use, (<<%=))
-import qualified Wayland.Server.System as Sys
-import Control.Monad.Trans (MonadTrans(..))
-import Foreign.C (peekCString, newCString, withCString)
-import Foreign.C.Types (CInt)
-import Foreign (Ptr, nullPtr, new, newStablePtr, castStablePtrToPtr, castPtrToStablePtr, deRefStablePtr, freeStablePtr, Storable(..), Int32, castPtr, withArray, with, allocaArray0, FunPtr, plusPtr)
-import Data.IORef (IORef, newIORef, writeIORef, readIORef)
-import Control.Monad.Reader (ReaderT, MonadReader(..), runReaderT)
-import Control.Exception (bracket)
-import Data.Functor (($>))
-import Control.Monad (when)
-import Data.Maybe (isJust)
-import qualified Data.Map as M
-import Foreign.Marshal (newArray)
-import Data.Word (Word32)
-import System.Mem.StableName (StableName, makeStableName)
-import Data.Hashable (Hashable(..))
-import Control.Monad.Cont (ContT(..))
-
-data EventSource = EventSource (FunPtr Sys.WLEventLoopSignalFunc) (IORef Sys.WLEventSource)
-  deriving (Eq)
-
-data Global = Global (FunPtr Sys.WLGlobalBindFunc) (IORef Sys.WLGlobal)
-  deriving (Eq)
-
--- IORef set to nullPtr once destroyed.
-data ObjectID = ObjectID (StableName (IORef Sys.WLResource)) (IORef Sys.WLResource)
-  deriving (Eq)
-
-instance Ord ObjectID where
-  (ObjectID nameA _) <= (ObjectID nameB _) = hash nameA <= hash nameB
-
-instance Hashable ObjectID where
-  hashWithSalt s (ObjectID name _) = hashWithSalt s name
-
-instance Show ObjectID where
-  show (ObjectID name _) = "ObjectID " ++ show (hash name)
-
-data Nullability
-  = AllowNull
-  | NotNull
-  deriving (Show, Eq, Ord)
-
-data ArgumentDesc
-  = ArgumentInt
-  | ArgumentUInt
-  | ArgumentFixed
-  | ArgumentString !Nullability
-  | ArgumentObject !Nullability !InterfaceDesc
-  | ArgumentNewID  !InterfaceDesc
-  | ArgumentArray
-  | ArgumentFD
-  deriving (Show, Eq, Ord)
-
-data MessageDesc
-  = MessageDesc { msgName              :: !String
-                , msgSignature         :: ![ArgumentDesc]
-                , msgSince             :: !Int
-                , msgIsDestructor      :: !Bool
-                }
-  deriving (Show, Eq, Ord)
-
-data InterfaceDesc
-  = InterfaceDesc { ifName     :: !String
-                  , ifVersion  :: !Int
-                  , ifRequests :: ![MessageDesc]
-                  , ifEvents   :: ![MessageDesc]
-                  }
-  deriving (Show, Eq, Ord)
-
-class (Typeable r, Show r) => RequestClass r where
-
-class (Typeable e, Show e) => EventClass e where
-
-data Request = forall a. RequestClass a => Request a
-
-newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (StateT DisplayState (ReaderT Display IO)) a }
-  deriving (Functor, Applicative, Monad, MonadIO, MonadState s, MonadFail)
-
-type RequestHandler s = Request -> DisplayM s ()
-
-newtype EventLoop = EventLoop { handleEvent :: Request -> IO () }
-
-data Display
-  = Display { display         :: !Sys.WLDisplay
-            , activeEventLoop :: !(IORef (Maybe EventLoop))
-            }
-
-data DisplayState
-  = DisplayState { _typeInterfaces   :: !(M.Map TypeRep       (Ptr Sys.WLInterface))
-                 , _nativeInterfaces :: !(M.Map InterfaceDesc (Ptr Sys.WLInterface))
-                 }
-
-makeLenses ''DisplayState
-
-class (Typeable r, RequestClass (ResourceRequest r), EventClass (ResourceEvent r)) => ResourceClass r where
-  type ResourceRequest r :: Type
-  type ResourceEvent   r :: Type
-  objectID  :: r        -> ObjectID
-  fromID    :: ObjectID -> r
-  interface :: Proxy r  -> InterfaceDesc
-  marshalEvent     :: ArgumentMarshaller m   => Proxy r -> ResourceEvent r -> m Int
-  demarshalRequest :: ArgumentDemarshaller m => r -> Int -> m (ResourceRequest r)
-  eventSignature   :: Proxy r -> ResourceEvent r   -> MessageDesc
-  requestSignature :: Proxy r -> ResourceRequest r -> MessageDesc
-
-class (Monad m, MonadFail m) => ArgumentMarshaller m where
-  marshalInt    :: Int                  -> m ()
-  marshalUInt   :: Word                 -> m ()
-  marshalFixed  :: Float                -> m ()
-  marshalString :: String               -> m ()
-  marshalObject :: ResourceClass r => r -> m ()
-  marshalNewID  :: ResourceClass r => r -> m ()
-  marshalArray  :: Storable a => [a]    -> m ()
-  marshalFD     :: Int32                -> m ()
-
-class (Monad m, MonadFail m) => ArgumentDemarshaller m where
-  demarshalInt    :: m Int
-  demarshalUInt   :: m Word
-  demarshalFixed  :: m Float
-  demarshalString :: m String
-  demarshalObject :: ResourceClass r => m r
-  demarshalNewID  :: ResourceClass r => m r
-  demarshalArray  :: Storable a => m [a]
-  demarshalFD     :: m Int32
-
-instance Show Request where
-  show (Request r) = show r
-
-type instance Zoomed (DisplayM s) = Zoomed (StateT s (StateT DisplayState (ReaderT Display IO)))
-
-instance Zoom (DisplayM s) (DisplayM t) s t where
-  zoom l (DisplayM m) = DisplayM (zoom l m)
-
-getDisplay :: DisplayM s Display
-getDisplay = DisplayM $ lift $ lift ask
-
-liftDisplayState :: StateT DisplayState (ReaderT Display IO) a -> DisplayM s a
-liftDisplayState m = DisplayM $ lift m
-
-fromRequest :: Typeable a => Request -> Maybe a
-fromRequest (Request x) = cast x
-
-withDisplay :: s -> DisplayM s a -> IO (a, s)
-withDisplay initialState f = bracket Sys.wlDisplayCreate Sys.wlDisplayDestroy $ \sysDisp -> do
-  eventLoop <- newIORef Nothing
-  let disp = Display { display         = sysDisp
-                     , activeEventLoop = eventLoop
-                     }
-      dispState = DisplayState { _typeInterfaces   = M.empty
-                               , _nativeInterfaces = M.empty
-                               }
-  (res, _) <- runReaderT (runStateT (runStateT (runDisplayM f) initialState) dispState) disp
-  pure res
-
-bindSocket :: DisplayM s String
-bindSocket = do
-  disp <- getDisplay
-  name <- liftIO $ Sys.wlDisplayAddSocketAuto (display disp)
-  liftIO $ peekCString name
-
-processRequests :: RequestHandler s -> DisplayM s ()
-processRequests h = do
-  disp <- getDisplay
-  stateBefore <- get
-  displayStateBefore <- liftDisplayState get
-  stateRef <- liftIO $ newIORef (stateBefore, displayStateBefore)
-  let handler :: Request -> IO ()
-      handler r = do
-        (s, ds) <- readIORef stateRef
-        ((_, s'), ds') <- runReaderT (runStateT (runStateT (runDisplayM (h r)) s) ds) disp
-        writeIORef stateRef (s', ds')
-  loop <- liftIO $ readIORef (activeEventLoop disp)
-  when (isJust loop) (fail "Cannot start an event loop from within an event handler.")
-  liftIO $ writeIORef (activeEventLoop disp) (Just (EventLoop handler))
-  liftIO $ Sys.wlDisplayRun (display disp)
-  (stateAfter, displayStateAfter) <- liftIO $ readIORef stateRef
-  put stateAfter
-  liftDisplayState $ put displayStateAfter
-
-registerGlobal :: forall r bindReq unbindReq s. ResourceClass r => RequestClass bindReq => RequestClass unbindReq => (r -> bindReq) -> (r -> unbindReq) -> Int -> DisplayM s Global
-registerGlobal mkBindReq mkUnbindReq version = do
-  disp <- getDisplay
-  iface <- getInterface (Proxy :: Proxy r)
-  let dispatcher :: Ptr () -> Sys.WLResource -> Word32 -> Ptr Sys.WLMessage -> Ptr Sys.WLArgument -> IO CInt
-      dispatcher _ res opcode _ _ = do
-        handlePtr <- castPtrToStablePtr <$> Sys.wlResourceGetUserData res
-        objID@(ObjectID _ _) <- deRefStablePtr handlePtr
-        putStrLn $ "Handling request " ++ show opcode ++ " for " ++ show objID
-        -- TODO: Handle request
-        pure 0
-  let destroy :: Sys.WLResource -> IO ()
-      destroy res = do
-        handlePtr <- castPtrToStablePtr <$> Sys.wlResourceGetUserData res
-        objID@(ObjectID _ handle) <- deRefStablePtr handlePtr
-        writeIORef handle (Sys.WLResource nullPtr)
-        freeStablePtr handlePtr
-        let req = mkUnbindReq (fromID objID)
-        runRequest disp (Request req)
-        pure ()
-  let createObject :: Sys.WLClient -> Ptr () -> Word32 -> Word32 -> IO ()
-      createObject client _ ver protID = do
-        res <- Sys.wlResourceCreate client iface (fromIntegral ver) protID
-        handle <- newIORef res
-        name <- makeStableName handle
-        let objID = ObjectID name handle
-        handlePtr <- newStablePtr objID
-        dis <- Sys.wrapWLDispatcherFunc dispatcher
-        des <- Sys.wrapWLResourceDestroyFunc destroy
-        -- TODO: Free dis and des
-        Sys.wlResourceSetDispatcher res dis nullPtr (castStablePtrToPtr handlePtr) des
-        let req = mkBindReq (fromID objID)
-        runRequest disp (Request req)
-        pure ()
-  liftIO $ do
-    func <- Sys.wrapWLGlobalBindFunc createObject
-    global <- Sys.wlGlobalCreate (display disp) iface (fromIntegral version) nullPtr func
-    globalRef <- newIORef global
-    -- TODO: Free func
-    pure $ Global func globalRef
-
-unregisterGlobal :: Global -> DisplayM s ()
-unregisterGlobal _ = pure ()
-
-runRequest :: Display -> Request -> IO ()
-runRequest disp r = do
-  loop <- readIORef (activeEventLoop disp)
-  case loop of
-    Just handler -> handleEvent handler r
-    Nothing      -> putStrLn $ "Lost request because no event loop is active: " ++ show r
-
-registerSignalEvent :: RequestClass req => req -> CInt -> DisplayM s EventSource
-registerSignalEvent r sig = do
-  disp <- getDisplay
-  liftIO $ do
-    loop <- Sys.wlDisplayGetEventLoop (display disp)
-    func <- Sys.wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0
-    src <- Sys.wlEventLoopAddSignal loop sig func nullPtr
-    srcRef <- newIORef src
-    -- TODO: Free func
-    pure $ EventSource func srcRef
-
-requestTermination :: DisplayM s ()
-requestTermination = do
-  disp <- getDisplay
-  liftIO $ Sys.wlDisplayTerminate (display disp)
-
-wrapInterface :: InterfaceDesc -> DisplayM s (Ptr Sys.WLInterface)
-wrapInterface i = do
-  let mkArgumentType :: ArgumentDesc -> DisplayM s (Ptr Sys.WLInterface)
-      mkArgumentType (ArgumentObject _ a) = wrapInterface a
-      mkArgumentType (ArgumentNewID a)    = wrapInterface a
-      mkArgumentType _                    = pure nullPtr
-  let mkArgument :: ArgumentDesc -> String
-      mkArgument ArgumentInt                  = "i"
-      mkArgument ArgumentUInt                 = "u"
-      mkArgument ArgumentFixed                = "f"
-      mkArgument (ArgumentString NotNull)     = "s"
-      mkArgument (ArgumentString AllowNull)   = "?s"
-      mkArgument (ArgumentObject NotNull _)   = "o"
-      mkArgument (ArgumentObject AllowNull _) = "?o"
-      mkArgument (ArgumentNewID _)            = "n"
-      mkArgument ArgumentArray                = "a"
-      mkArgument ArgumentFD                   = "h"
-  let mkMessage :: MessageDesc -> DisplayM s Sys.WLMessage
-      mkMessage m = do
-        name      <- liftIO $ newCString (msgName m)
-        signature <- liftIO $ newCString (show (msgSince m) ++ (msgSignature m >>= mkArgument))
-        types     <- mapM mkArgumentType (msgSignature m) >>= liftIO . newArray
-        pure $ Sys.WLMessage { Sys.msgName      = name
-                             , Sys.msgSignature = signature
-                             , Sys.msgTypes     = types
-                             }
-  let mkInterface :: DisplayM s (Ptr Sys.WLInterface)
-      mkInterface = do
-        name    <- liftIO $ newCString (ifName i)
-        methods <- mapM mkMessage (ifRequests i) >>= liftIO . newArray
-        events  <- mapM mkMessage (ifEvents i)   >>= liftIO . newArray
-        liftIO $ new $ Sys.WLInterface { Sys.ifName        = name
-                                       , Sys.ifVersion     = fromIntegral $ ifVersion i
-                                       , Sys.ifMethodCount = fromIntegral $ length (ifRequests i)
-                                       , Sys.ifMethods     = methods
-                                       , Sys.ifEventCount  = fromIntegral $ length (ifEvents i)
-                                       , Sys.ifEvents      = events
-                                       }
-  existing <- liftDisplayState $ use nativeInterfaces
-  case M.lookup i existing of
-    Just ptr -> pure ptr
-    Nothing  -> do ptr <- mkInterface
-                   -- TODO: Free ptr
-                   liftDisplayState $ nativeInterfaces %= M.insert i ptr
-                   pure ptr
-
-getInterface :: ResourceClass r => Proxy r -> DisplayM s (Ptr Sys.WLInterface)
-getInterface p = do
-  existing <- liftDisplayState $ use typeInterfaces
-  case M.lookup (typeRep p) existing of
-    Just ptr -> pure ptr
-    Nothing  -> do ptr <- wrapInterface (interface p)
-                   liftDisplayState $ typeInterfaces %= M.insert (typeRep p) ptr
-                   pure ptr
-
-data ArgumentIteratorState
-  = ArgumentIteratorState { _argNext          :: !(Ptr Sys.WLArgument)
-                          , _argRemaining     :: !Int
-                          }
-  deriving (Show)
-
-makeLenses ''ArgumentIteratorState
-
-newtype ArgumentIterator r a = ArgumentIterator { runArgumentIterator :: StateT ArgumentIteratorState (ContT r IO) a }
-  deriving (Functor, Applicative, Monad, MonadFail, MonadState ArgumentIteratorState, MonadIO)
-
-advanceIterator :: ArgumentIterator r (Ptr Sys.WLArgument)
-advanceIterator = do
-  next      <- argNext      <<%= \p -> plusPtr p (sizeOf (undefined :: Sys.WLArgument))
-  remaining <- argRemaining <<%= (+(-1))
-  when (remaining == 0) (fail "Out of range for argument")
-  pure next
-
-getObjectForHandle :: ResourceClass r => r -> IO Sys.WLResource
-getObjectForHandle r = fetch (objectID r)
-  where fetch (ObjectID _ handle) = readIORef handle >>= check
-        check res@(Sys.WLResource ptr) | ptr == nullPtr = fail "Invalid object handle."
-                                       | otherwise      = pure res
-
-liftCont :: ((a -> IO r) -> IO r) -> ArgumentIterator r a
-liftCont = ArgumentIterator . lift . ContT
-
-instance ArgumentMarshaller (ArgumentIterator r) where
-  marshalInt v = do
-    arg <- advanceIterator
-    liftIO $ Sys.wlArgumentPokeInt arg (fromIntegral v)
-  marshalUInt v = do
-    arg <- advanceIterator
-    liftIO $ Sys.wlArgumentPokeUInt arg (fromIntegral v)
-  marshalFixed v = do
-    arg <- advanceIterator
-    liftIO $ Sys.wlArgumentPokeFixed arg (Sys.WLFixed (round (v * 256)))
-  marshalFD v = do
-    arg <- advanceIterator
-    liftIO $ Sys.wlArgumentPokeFD arg (fromIntegral v)
-  marshalString v = do
-    arg <- advanceIterator
-    str <- liftCont $ withCString v
-    liftIO $ Sys.wlArgumentPokeString arg str
-  marshalObject v = do
-    arg <- advanceIterator
-    obj <- liftIO $ getObjectForHandle v
-    liftIO $ Sys.wlArgumentPokeObject arg obj
-  marshalNewID v = do
-    arg <- advanceIterator
-    obj <- liftIO $ getObjectForHandle v
-    liftIO $ Sys.wlArgumentPokeObject arg obj
-  marshalArray v = do
-    arg <- advanceIterator
-    let len = fromIntegral $ length v * sizeOf (head v)
-    buf <- liftCont $ withArray v
-    arr <- liftCont $ with $ Sys.WLArray { Sys.arrSize  = len
-                                         , Sys.arrAlloc = len
-                                         , Sys.arrData  = castPtr buf
-                                         }
-    liftIO $ Sys.wlArgumentPokeArray arg arr
-
-sendEvent :: forall r s. ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
-sendEvent res e = liftIO $ do
-  let params = msgSignature (eventSignature (Proxy :: Proxy r) e)
-  ptr <- getObjectForHandle res
-  allocaArray0 (length params) $ \buffer ->
-    let s = ArgumentIteratorState { _argNext          = buffer
-                                  , _argRemaining     = length params
-                                  }
-        handler (opcode, _) = Sys.wlResourcePostEventArray ptr (fromIntegral opcode) buffer
-    in runContT (runStateT (runArgumentIterator (marshalEvent (Proxy :: Proxy r) e)) s) handler
-
-flushEvents :: DisplayM s ()
-flushEvents = do
-  disp <- getDisplay
-  liftIO $ Sys.wlDisplayFlushClients (display disp)
-
-destroyResource :: ResourceClass r => r -> DisplayM s ()
-destroyResource r = liftIO $ do
-  ptr <- getObjectForHandle r
-  Sys.wlResourceDestroy ptr
+import Wayland.Server.Interface
+import Wayland.Server.Object
+import Wayland.Server.Display
diff --git a/wayland/Wayland/Server/Client.hs b/wayland/Wayland/Server/Client.hs
new file mode 100644
index 0000000..99d11d6
--- /dev/null
+++ b/wayland/Wayland/Server/Client.hs
@@ -0,0 +1,18 @@
+module Wayland.Server.Client
+  ( Client
+  , unwrapClient
+  , wrapClient
+  ) where
+
+import Wayland.Server.System
+
+data Client = Client WLClient
+  deriving (Show, Eq)
+
+unwrapClient :: Client -> IO WLClient
+unwrapClient (Client c) = pure c
+
+wrapClient :: WLClient -> IO Client
+wrapClient c = pure $ Client c
+
+-- TODO: Lifecycle
diff --git a/wayland/Wayland/Server/Display.hs b/wayland/Wayland/Server/Display.hs
new file mode 100644
index 0000000..2a30323
--- /dev/null
+++ b/wayland/Wayland/Server/Display.hs
@@ -0,0 +1,262 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- |
+-- Module     : Wayland.Server.Display
+-- Description: Entrypoint for the server, managing the request loop and server state.
+--
+-- A wayland server provides a "display" that can be controlled using a UNIX socket. The server runs an event loop
+-- handling requests. These requests may be events, requests to create objects, or requests for a particular object
+-- instance.
+
+module Wayland.Server.Display
+  ( -- * The Display Monad
+    DisplayM
+  , withDisplay
+  , bindSocket
+  ,  -- * Processing Requests
+    RequestHandler
+  , processRequests
+  , requestTermination
+  , -- * Managing Objects
+    Global
+  , registerGlobal
+  , unregisterGlobal
+  , createObject
+  , destroyObject
+  , sendEvent
+  , flushEvents
+  , -- * Event Sources
+    EventSource
+  , registerSignalEvent
+  ) where
+
+import Data.Maybe (isJust)
+import Data.Functor (($>))
+import Data.Typeable (Proxy(..))
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Foreign (Ptr, FunPtr, Word32, nullPtr)
+import Foreign.C (peekCString, CInt)
+import Lens.Micro.TH (makeLenses)
+import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
+import Control.Monad.State.Strict (StateT(..), MonadState(..))
+import Control.Monad.Reader (ReaderT(..), ask, asks)
+import Control.Monad.Trans (MonadIO(..), MonadTrans(..))
+import Control.Exception (bracket)
+import Control.Monad (when)
+import Wayland.Server.System
+import Wayland.Server.Object (ObjectCache, Request(..), newObjectCache, destroyObjectCache, createResource, RequestClass, Object(..), unwrapResource, resolveTypeInterface, sendResourceEvent, NewObject, createNewObject)
+import Wayland.Server.Client (wrapClient)
+
+-- | The display monad.
+--
+-- All server-related logic runs in this monad, including the initial set-up and all request handlers. The monad
+-- provides custom state and support for IO operations.
+newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (ReaderT Display (StateT DisplayState IO)) a }
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState s)
+
+-- | A function handling a type-erased request.
+--
+-- This handler is executed as part of the event loop.
+type RequestHandler s = Request -> DisplayM s ()
+
+-- | Read-only data related to the display.
+data Display
+  = Display { display         :: !WLDisplay                 -- ^ The underlying wl_display instance.
+            , activeEventLoop :: !(IORef (Maybe EventLoop)) -- ^ Mutable reference to the active request handler.
+            }
+
+-- | Mutable state for the display.
+newtype DisplayState = DisplayState { _stateObjectCache :: ObjectCache }
+
+-- | A function handling a request in the IO monad.
+--
+-- The event loop callback needs to retrieve the current state, run the request handler in a Display monad, and update
+-- the state.
+newtype EventLoop = EventLoop { handleEvent :: Request -> IO () }
+
+-- | Handle to an event source that dispatches requests to the event loop.
+--
+-- This may be a signal event source, timer event source, etc. The event source handle remains valid even after it has
+-- expired or after it was unregistered.
+data EventSource = EventSource (FunPtr WLEventLoopSignalFunc) (IORef WLEventSource)
+  deriving (Eq)
+
+-- | Handle to a global object shared between all clients.
+--
+-- For each client, the global can be "bound" to a specific object. The global handle remains valid even after it was
+-- unregistered.
+data Global = Global (FunPtr WLGlobalBindFunc) (IORef WLGlobal)
+  deriving (Eq)
+
+makeLenses ''DisplayState
+
+type instance Zoomed (DisplayM s) = Zoomed (StateT s (ReaderT Display (StateT DisplayState IO)))
+
+instance Zoom (DisplayM s) (DisplayM t) s t where
+  zoom l (DisplayM m) = DisplayM (zoom l m)
+
+-- | Lift a 'Display' reader operation into the display monad.
+liftDisplay :: ReaderT Display (StateT DisplayState IO) a -> DisplayM s a
+liftDisplay = DisplayM . lift
+
+-- | Lift a 'DisplayState' state operation into the display monad.
+liftDisplayState :: StateT DisplayState IO a -> DisplayM s a
+liftDisplayState = DisplayM . lift . lift
+
+-- | Get a reference to the underlying wl_display instance.
+getDisplay :: DisplayM s WLDisplay
+getDisplay = liftDisplay $ asks display
+
+-- | Get a function which can be used to handle a request.
+--
+-- This function can be used even before the event loop is started as it will use the mutable "activeEventLoop"
+-- reference which gets updated when the event loop is started.
+getRequestHandler :: DisplayM s (Request -> IO ())
+getRequestHandler = do
+  loopRef <- liftDisplay $ asks activeEventLoop
+  pure $ \req -> do
+    loop <- readIORef loopRef
+    case loop of
+      Just handler -> handleEvent handler req
+      Nothing      -> putStrLn $ "Lost request because no event loop is active: " ++ show req
+
+-- | Create a new display and execute the given action on it.
+--
+-- After executing the action, all resources associated with the display are cleaned up.
+withDisplay
+  :: s            -- ^ Initial state.
+  -> DisplayM s a -- ^ The display action to execute.
+  -> IO (a, s)    -- ^ IO monad returning the result and the resulting state.
+withDisplay initialState f = bracket wlDisplayCreate wlDisplayDestroy $ \sysDisp -> do
+  eventLoop <- newIORef Nothing
+  let disp = Display { display         = sysDisp
+                     , activeEventLoop = eventLoop
+                     }
+  objectCache <- newObjectCache
+  let dispState = DisplayState { _stateObjectCache = objectCache }
+  (res, dispState') <- runStateT (runReaderT (runStateT (runDisplayM f) initialState) disp) dispState
+  destroyObjectCache (_stateObjectCache dispState')
+  pure res
+
+-- | Bind the display to a UNIX socket so it is reachable from clients.
+--
+-- This will return the name of the Wayland display.
+bindSocket :: DisplayM s String
+bindSocket = do
+  disp <- getDisplay
+  name <- liftIO $ wlDisplayAddSocketAuto disp
+  liftIO $ peekCString name
+
+-- | Start the event loop for the display.
+--
+-- The display will then handle all requests using the provided handler until 'requestTermination' is called. The state
+-- may be modified by the request handler.
+processRequests :: RequestHandler s -> DisplayM s ()
+processRequests h = do
+  disp <- liftDisplay ask
+  stateBefore <- get
+  displayStateBefore <- liftDisplayState get
+  stateRef <- liftIO $ newIORef (stateBefore, displayStateBefore)
+  let handler :: Request -> IO ()
+      handler r = do
+        (s, ds) <- readIORef stateRef
+        ((_, s'), ds') <- runStateT (runReaderT (runStateT (runDisplayM (h r)) s) disp) ds
+        writeIORef stateRef (s', ds')
+  loop <- liftIO $ readIORef (activeEventLoop disp)
+  when (isJust loop) (error "Cannot start an event loop from within an event handler.")
+  liftIO $ writeIORef (activeEventLoop disp) (Just (EventLoop handler))
+  liftIO $ wlDisplayRun (display disp)
+  (stateAfter, displayStateAfter) <- liftIO $ readIORef stateRef
+  put stateAfter
+  liftDisplayState $ put displayStateAfter
+
+-- | Request the event loop to stop.
+--
+-- The 'processRequests' will return following this action.
+requestTermination :: DisplayM s ()
+requestTermination = do
+  disp <- getDisplay
+  liftIO $ wlDisplayTerminate disp
+
+-- | Create a new object instance.
+--
+-- If the NewObject instance has already been used to create an instance, the same instance is returned again.
+createObject
+  :: Object o
+  => RequestClass destroyReq
+  => NewObject o        -- ^ Handle describing the object to be created
+  -> (o -> destroyReq)  -- ^ Function creating a request dispatched after the object was destroyed.
+  -> DisplayM s o       -- ^ Display monad wrapping the newly created object.
+createObject o destroyHook = do
+  handle <- getRequestHandler
+  liftDisplayState $ zoom stateObjectCache $ createResource handle o destroyHook
+
+-- | Destroy an object instance.
+--
+-- This will invoke the object's "destroy" hook.
+destroyObject :: Object o => o -> DisplayM s ()
+destroyObject o = liftIO $ do
+  ptr <- unwrapResource o
+  wlResourceDestroy ptr
+
+-- | Send an event for an object to the client it is associated with.
+sendEvent :: Object o => o -> ObjectEvent o -> DisplayM s ()
+sendEvent o e = liftIO $ sendResourceEvent o e
+
+-- | Ensure that all queued events are sent out to clients.
+flushEvents :: DisplayM s ()
+flushEvents = do
+  disp <- getDisplay
+  liftIO $ wlDisplayFlushClients disp
+
+-- | Register a global object which can be bound by clients.
+--
+-- The object is published through the global wl_registry instance. When a client wants to instantiate the global
+-- object, the given "bind" request will be dispatched in the request loop.
+registerGlobal
+  :: forall o req s. Object o
+  => RequestClass req
+  => (NewObject o -> req) -- ^ Function used to create a request to bind the global object for a client.
+  -> Int                  -- ^ Version of the global published.
+  -> DisplayM s Global    -- ^ Display monad wrapping a handle to the global which can be used to unregister it.
+registerGlobal mkReq version = do
+  disp <- getDisplay
+  handle <- getRequestHandler
+  iface <- liftDisplayState $ zoom stateObjectCache $ resolveTypeInterface (Proxy :: Proxy o)
+  let bind :: WLClient -> Ptr () -> Word32 -> Word32 -> IO ()
+      bind client _ ver objID = do wrappedClient <- wrapClient client
+                                   obj <- createNewObject wrappedClient objID (fromIntegral ver)
+                                   handle $ Request (mkReq obj)
+  liftIO $ do
+    bindFunc <- wrapWLGlobalBindFunc bind
+    global <- wlGlobalCreate disp iface (fromIntegral version) nullPtr bindFunc
+    globalRef <- newIORef global
+    -- TODO: Free func
+    pure $ Global bindFunc globalRef
+
+-- | Unregister a global after it is no longer available.
+unregisterGlobal :: Global -> DisplayM s ()
+unregisterGlobal _ = pure ()
+
+-- | Register an event to be dispatched in the request loop when a UNIX signal is sent to the server process.
+registerSignalEvent
+  :: RequestClass req
+  => req                    -- ^ The request dispatched when the signal is received.
+  -> CInt                   -- ^ The code of the UNIX signal to listen for.
+  -> DisplayM s EventSource -- ^ Display monad wrapping a handle to the event source which can be used to unregister it.
+registerSignalEvent r sig = do
+  disp <- getDisplay
+  handle <- getRequestHandler
+  liftIO $ do
+    loop <- wlDisplayGetEventLoop disp
+    func <- wrapWLEventLoopSignalFunc $ \_ _ -> handle (Request r) $> 0
+    src <- wlEventLoopAddSignal loop sig func nullPtr
+    srcRef <- newIORef src
+    -- TODO: Free func
+    pure $ EventSource func srcRef
diff --git a/wayland/Wayland/Server/Interface.hs b/wayland/Wayland/Server/Interface.hs
new file mode 100644
index 0000000..07cc34e
--- /dev/null
+++ b/wayland/Wayland/Server/Interface.hs
@@ -0,0 +1,159 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+-- |
+-- Module     : Wayland.Server.Interface
+-- Description: Description of the API for an object.
+--
+-- This module provides data types for describing the requests and events supported by a Wayland object. This is used
+-- for marshalling/demarshalling the message using the binary wire protocol.
+--
+-- In addition, this module provides support for converting interface descriptions into their C equivalents and caching
+-- the results (ensuring pointer equality for the same interface).
+
+module Wayland.Server.Interface
+  ( -- * Interface Descriptions
+    InterfaceDesc(..)
+  , MessageDesc(..)
+  , ArgumentDesc(..)
+  , Nullability(..)
+  , -- * Native Interfaces
+    InterfaceCache
+  , InterfaceCacheState
+  , newInterfaceCache
+  , destroyInterfaceCache
+  , resolveInterface
+  ) where
+
+import Control.Monad.State.Strict (MonadState(..), StateT)
+import Control.Monad.Trans (MonadIO(..))
+import Foreign (Ptr, nullPtr, newArray, new, free, peekArray, Storable(..))
+import Foreign.C (newCString)
+import qualified Wayland.Server.System as Sys
+import qualified Data.Map as M
+
+-- | Description of a Wayland interface and the functionality it provides.
+--
+-- This is analogous to the wl_interface structure in libwayland and is converted into it as needed.
+--
+-- An interface can be implemented by an object which is associated with a client.
+data InterfaceDesc
+  = InterfaceDesc { ifName     :: !String        -- ^ Name of the interface (for example, "wl_output").
+                  , ifVersion  :: !Int           -- ^ Version of the interface described in this data structure.
+                  , ifRequests :: ![MessageDesc] -- ^ The requests a server should handle to implement the interface.
+                  , ifEvents   :: ![MessageDesc] -- ^ The events sent out by a server for instances of the interface.
+                  }
+  deriving (Show, Eq, Ord)
+
+-- | Description of a message sent between the server and a client (either a request or an event).
+--
+-- A message operates on an object implementing an interface.
+data MessageDesc
+  = MessageDesc { msgName              :: !String         -- ^ Name of the protocol message.
+                , msgArguments         :: ![ArgumentDesc] -- ^ The argument types passed to the message.
+                , msgSince             :: !Int            -- ^ Protocol version where the message was introduced.
+                , msgIsDestructor      :: !Bool           -- ^ Indicates whether this is a request to destroy an object.
+                }
+  deriving (Show, Eq, Ord)
+
+-- | Description of an argument in the signature of a message.
+data ArgumentDesc
+  = ArgumentInt
+  | ArgumentUInt
+  | ArgumentFixed
+  | ArgumentString !Nullability
+  | ArgumentObject !Nullability !InterfaceDesc
+  | ArgumentNewID               !InterfaceDesc
+  | ArgumentArray
+  | ArgumentFD
+  deriving (Show, Eq, Ord)
+
+-- | Describes whether a string/object argument in a message is optional.
+data Nullability
+  = Nullable
+  | NotNull
+  deriving (Show, Eq, Ord)
+
+-- | State used to cache C interfaces.
+--
+-- The wl_interface instances are cached so the same interface description always yields the same wl_interface pointer.
+newtype InterfaceCache = InterfaceCache (M.Map InterfaceDesc (Ptr Sys.WLInterface))
+
+-- | A state monad providing an instance of 'InterfaceCache'.
+type InterfaceCacheState = StateT InterfaceCache IO
+
+-- | Initialize an interface cache.
+newInterfaceCache :: IO InterfaceCache
+newInterfaceCache = pure $ InterfaceCache M.empty
+
+-- | Destroy an interface cache, freeing all acquired resources.
+--
+-- This should only be done after no wl_interface instances are referenced as it will free their underlying memory.
+destroyInterfaceCache :: InterfaceCache -> IO ()
+destroyInterfaceCache (InterfaceCache m) =
+  let freeMessage :: Sys.WLMessage -> IO ()
+      freeMessage msg = do
+        free (Sys.msgName msg)
+        free (Sys.msgSignature msg)
+        free (Sys.msgTypes msg)
+      freeInterface :: Ptr Sys.WLInterface -> IO ()
+      freeInterface iface = do
+        iface' <- peek iface
+        peekArray (fromIntegral (Sys.ifMethodCount iface')) (Sys.ifMethods iface') >>= mapM_ freeMessage
+        peekArray (fromIntegral (Sys.ifEventCount iface'))  (Sys.ifEvents iface')  >>= mapM_ freeMessage
+        free (Sys.ifName iface')
+        free (Sys.ifMethods iface')
+        free (Sys.ifEvents iface')
+        free iface
+  in mapM_ freeInterface m
+
+-- | Resolve a native wl_interface pointer for an interface description.
+--
+-- This will first attempt to use an existing instance from the 'InterfaceCache'. If there is none, it will create a new
+-- native interface and put it in the cache. Resources are freed using 'destroyInterfaceCache'.
+--
+-- Resolving an interface may also require resolving other interfaces used as arguments, thus this function is
+-- implemented recursively.
+resolveInterface :: InterfaceDesc -> InterfaceCacheState (Ptr Sys.WLInterface)
+resolveInterface i = do
+  let mkArgumentType :: ArgumentDesc -> InterfaceCacheState (Ptr Sys.WLInterface)
+      mkArgumentType (ArgumentObject _ a) = resolveInterface a
+      mkArgumentType (ArgumentNewID a)    = resolveInterface a
+      mkArgumentType _                    = pure nullPtr
+  let mkArgument :: ArgumentDesc -> String
+      mkArgument ArgumentInt                 = "i"
+      mkArgument ArgumentUInt                = "u"
+      mkArgument ArgumentFixed               = "f"
+      mkArgument (ArgumentString NotNull)    = "s"
+      mkArgument (ArgumentString Nullable)   = "?s"
+      mkArgument (ArgumentObject NotNull _)  = "o"
+      mkArgument (ArgumentObject Nullable _) = "?o"
+      mkArgument (ArgumentNewID _)           = "n"
+      mkArgument ArgumentArray               = "a"
+      mkArgument ArgumentFD                  = "h"
+  let mkMessage :: MessageDesc -> InterfaceCacheState Sys.WLMessage
+      mkMessage m = do
+        name      <- liftIO $ newCString (msgName m)
+        signature <- liftIO $ newCString (show (msgSince m) ++ (msgArguments m >>= mkArgument))
+        types     <- mapM mkArgumentType (msgArguments m) >>= liftIO . newArray
+        pure $ Sys.WLMessage { Sys.msgName      = name
+                             , Sys.msgSignature = signature
+                             , Sys.msgTypes     = types
+                             }
+  let mkInterface :: InterfaceCacheState (Ptr Sys.WLInterface)
+      mkInterface = do
+        name    <- liftIO $ newCString (ifName i)
+        methods <- mapM mkMessage (ifRequests i) >>= liftIO . newArray
+        events  <- mapM mkMessage (ifEvents   i) >>= liftIO . newArray
+        liftIO $ new $ Sys.WLInterface { Sys.ifName = name
+                                       , Sys.ifVersion = fromIntegral (ifVersion i)
+                                       , Sys.ifMethodCount = fromIntegral (length (ifRequests i))
+                                       , Sys.ifMethods     = methods
+                                       , Sys.ifEventCount  = fromIntegral (length (ifEvents i))
+                                       , Sys.ifEvents      = events
+                                       }
+  InterfaceCache existing <- get
+  case M.lookup i existing of
+    Just ptr -> pure ptr
+    Nothing  -> do ptr <- mkInterface
+                   put $ InterfaceCache $ M.insert i ptr existing
+                   pure ptr
diff --git a/wayland/Wayland/Server/Object.hs b/wayland/Wayland/Server/Object.hs
new file mode 100644
index 0000000..1437cc9
--- /dev/null
+++ b/wayland/Wayland/Server/Object.hs
@@ -0,0 +1,417 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ExistentialQuantification #-}
+
+-- |
+-- Module     : Wayland.Server.Object
+-- Description: Low-level API for wrapping Wayland object/resource handles.
+--
+-- Objects are represented as wl_resources in libwayland. This module wraps a resource, providing an opaque handle to it
+-- that is valid even after the underlying resource is destroyed. This is useful for storing the resource handle in a
+-- map and associating other data with it, cleaning it up only after its destruction.
+
+module Wayland.Server.Object
+  ( -- * Handles
+    Object(..)
+  , AnyObject
+  , NewObject
+  , createNewObject
+  , RequestClass
+  , EventClass
+  , Request(..)
+  , fromRequest
+  , ArgumentMarshaller(..)
+  , ArgumentDemarshaller(..)
+  , -- * State
+    ObjectCache
+  , ObjectCacheState
+  , newObjectCache
+  , destroyObjectCache
+  , resolveTypeInterface
+  , -- * Lifecycle
+    unwrapResource
+  , wrapResource
+  , createResource
+  , sendResourceEvent
+  ) where
+
+import System.Mem.StableName (makeStableName, StableName)
+import Data.Kind (Type)
+import Data.Hashable (Hashable(..))
+import Data.IORef (readIORef, newIORef, writeIORef, IORef)
+import Data.Typeable (Proxy(..), TypeRep, typeRep, Typeable, cast)
+import Foreign
+import Foreign.C (withCString, peekCString, CInt)
+import Lens.Micro.Mtl ((<<%=), use, (%=), zoom)
+import Lens.Micro.TH (makeLenses)
+import Control.Monad.State.Strict (StateT(..), MonadState)
+import Control.Monad.Cont (ContT(..))
+import Control.Monad.Trans (MonadIO(..), MonadTrans(..))
+import Control.Monad (when)
+import Wayland.Server.System
+import Wayland.Server.Interface (MessageDesc(..), InterfaceDesc, InterfaceCache, newInterfaceCache, destroyInterfaceCache, resolveInterface)
+import qualified Data.Map as M
+import Wayland.Server.Client (Client, unwrapClient)
+
+-- | The primary data type for typed object handles.
+--
+-- An instance of the Object class wraps an opaque object handle ('AnyObject') and additionally provides information
+-- about the object's interface.
+class (Typeable o, RequestClass (ObjectRequest o), EventClass (ObjectEvent o)) => Object o where
+  -- | Associated type for requests sent to object instances.
+  type ObjectRequest o :: Type
+  -- | Associated type for events emitted by object instances.
+  type ObjectEvent o :: Type
+
+  -- | Unwrap this typed object into an opaque object handle.
+  toAny :: o -> AnyObject
+  -- | Create a typed object from an opaque object handle.
+  fromAny :: AnyObject -> o
+
+  -- | Provide an interface description for objects of this type.
+  describeInterface :: Proxy o -> InterfaceDesc
+  -- | Provide a message description for an event instance.
+  eventSignature :: Proxy o -> ObjectEvent o -> MessageDesc
+  -- | Provide a message description for a request instance.
+  requestSignature :: Proxy o -> ObjectRequest o -> MessageDesc
+
+  -- | Marshal the arguments provided in the event instance into an argument marshaller.
+  --
+  -- This should marshal exactly @length . msgArguments . eventSignature@ arguments for the passed event and match the
+  -- types described in the signature. After that, the opcode for the event should be returned.
+  marshalEvent
+    :: ArgumentMarshaller m -- ^ Monad used to write marshalled arguments.
+    => Proxy o              -- ^ Proxy for the object type this event is referring to.
+    -> ObjectEvent o        -- ^ The event that should be marshalled.
+    -> m Int                -- ^ Argument marshaller returning the event's opcode.
+
+  -- | Demarshal the arguments provided into a request instance using an argument demarshaller.
+  --
+  -- This should demarshal exactly @length . msgArguments . requestSignature@ arguments using the demarshaller interface
+  -- and match the types described in the signature.
+  demarshalRequest
+    :: ArgumentDemarshaller m -- ^ Monad used to extract marshalled arguments.
+    => o                      -- ^ The instance this request is referring to.
+    -> Int                    -- ^ The opcode of the request.
+    -> m (ObjectRequest o)    -- ^ Argument demarshaller returning the demarshalled request.
+
+-- | A request for an object sent by a client.
+--
+-- The request usually includes the object it is referring to, as well as arguments provided by the client.
+--
+-- The request's type is erased and it is then processed by the display's event loop.
+class (Typeable r, Show r) => RequestClass r where
+
+-- | An event that can be emitted on an object by the server.
+--
+-- The event stores the arguments passed to the client.
+class (Typeable e, Show e) => EventClass e where
+
+-- | A type-erased request.
+data Request = forall r. RequestClass r => Request r
+
+-- | A monad providing an environment for marshalling a fixed number of arguments of various types.
+--
+-- For libwayland, the arguments are stored into wl_arguments. It is considered a programmer error to write more
+-- arguments than expected by an event or different argument types than the ones specified.
+class Monad m => ArgumentMarshaller m where
+  marshalInt    :: Int                     -> m ()
+  marshalUInt   :: Word                    -> m ()
+  marshalFixed  :: Float                   -> m ()
+  marshalString :: String                  -> m ()
+  marshalObject :: Object o => o           -> m ()
+  marshalNewID  :: Object o => NewObject o -> m ()
+  marshalArray  :: Storable a => [a]       -> m ()
+  marshalFD     :: Int32                   -> m ()
+
+-- | A monad providing an environment for reading a fixed number of arguments of various types.
+--
+-- For libwayland, the arguments are read from wl_arguments. It is considered a programmer error to read more arguments
+-- than expected by a request or different argument types than the ones specified.
+class Monad m => ArgumentDemarshaller m where
+  demarshalInt    :: m Int
+  demarshalUInt   :: m Word
+  demarshalFixed  :: m Float
+  demarshalString :: m String
+  demarshalObject :: Object o => m o
+  demarshalNewID  :: Object o => m (NewObject o)
+  demarshalArray  :: Storable a => m [a]
+  demarshalFD     :: m Int32
+
+-- | An opaque handle to a Wayland object.
+--
+-- The handle remains valid and can be used for equality checks even after the underlying libwayland resource was
+-- destroyed. This is realized using an IORef which is set to nullPtr once the resource is destroyed. The IORef itself
+-- is used for equality checks.
+--
+-- In addition, a custom type-erased cleanup action is stored which is invoked once the resource is destroyed.
+data AnyObject
+  = AnyObject { objName        :: StableName (IORef WLResource) -- ^ Name used for hashing and ordering.
+              , objResource    :: IORef WLResource              -- ^ Reference to the underlying resource.
+              , objDestroyHook :: AnyObject -> IO ()            -- ^ Function executed after the object was destroyed.
+              }
+
+-- | Handle to an object which has not yet been created but has an ID assigned by the client.
+--
+-- This handle can be used to create an object.
+data NewObject o
+  = NewObject { newClient  :: !Client            -- ^ The client this object is associated with.
+              , newID      :: !Word32            -- ^ Object ID of the new object.
+              , newVersion :: !CInt              -- ^ Protocol version to use for the newly created object.
+              , newObject  :: !(IORef (Maybe o)) -- ^ Reference to the object, assigned when it is created.
+              }
+
+-- | Data related to an object type.
+data TypeInfo
+  = TypeInfo { typeInterface    :: !(Ptr WLInterface)         -- ^ Reference to the libwayland interface for the type.
+             , typeDispatchFunc :: !(FunPtr WLDispatcherFunc) -- ^ The dispatcher function handling requests for the type.
+             }
+
+-- | State used to cache object-related data.
+data ObjectCache
+  = ObjectCache { _cacheTypeInfo    :: !(M.Map TypeRep TypeInfo)       -- ^ Type-specific information.
+                , _cacheDestroyFunc :: !(FunPtr WLResourceDestroyFunc) -- ^ Global destroy function for all objects.
+                , _cacheInterfaces  :: !InterfaceCache                 -- ^ Cache for native interfaces.
+                }
+
+-- | A state monad providing an instance of 'ObjectCache'.
+type ObjectCacheState = StateT ObjectCache IO
+
+-- | State used when iterating over a fixed number of wl_arguments.
+data ArgumentIterator
+  = ArgumentIterator { _argNext          :: !(Ptr WLArgument) -- ^ Pointer to the next argument to be processed.
+                     , _argRemaining     :: !Int              -- ^ Number of remaining arguments in the list.
+                     }
+
+-- | A state monad providing an instance of 'ArgumentIterator'.
+--
+-- The monad wraps a ContT monad to allow using alloca when wrapping arguments.
+newtype ArgumentIteratorState r a
+  = ArgumentIteratorState { runArgumentIteratorState :: StateT ArgumentIterator (ContT r IO) a }
+  deriving (Functor, Applicative, Monad, MonadState ArgumentIterator, MonadIO)
+
+makeLenses ''ObjectCache
+makeLenses ''ArgumentIterator
+
+instance Show Request where
+  show (Request r) = show r
+
+-- | Try to cast a type-erased request into a concrete 'RequestClass'.
+fromRequest :: RequestClass a => Request -> Maybe a
+fromRequest (Request x) = cast x
+
+instance Eq AnyObject where
+  a == b = objResource a == objResource b
+
+instance Ord AnyObject where
+  a <= b = hash (objName a) <= hash (objName b)
+
+instance Hashable AnyObject where
+  hashWithSalt s o = hashWithSalt s (objName o)
+
+instance Show AnyObject where
+  show o = "AnyObject " ++ show (hash (objName o))
+
+instance Show (NewObject o) where
+  show o = "NewObject " ++ show (newClient o) ++ " " ++ show (newID o)
+
+-- | Create a handle to an object that has yet to be created.
+createNewObject :: Client -> Word32 -> CInt -> IO (NewObject o)
+createNewObject client objID version = do
+  obj <- newIORef Nothing
+  pure $ NewObject { newClient  = client
+                   , newID      = objID
+                   , newVersion = version
+                   , newObject  = obj
+                   }
+
+-- | Initialize an object cache.
+newObjectCache :: IO ObjectCache
+newObjectCache = do
+  destroyFunc <- wrapWLResourceDestroyFunc destroyResource
+  interfaces  <- newInterfaceCache
+  pure $ ObjectCache { _cacheTypeInfo    = M.empty
+                     , _cacheDestroyFunc = destroyFunc
+                     , _cacheInterfaces  = interfaces
+                     }
+
+-- | Destroy an object cache, freeing all acquired resources.
+--
+-- This should only be done after no wl_resource instances are alive as it will free memory used by them.
+destroyObjectCache :: ObjectCache -> IO ()
+destroyObjectCache c = do
+  freeHaskellFunPtr (_cacheDestroyFunc c)
+  mapM_ (freeHaskellFunPtr . typeDispatchFunc) (_cacheTypeInfo c)
+  destroyInterfaceCache (_cacheInterfaces c)
+
+-- | Get the underlying Wayland resource wrapped by a typed object.
+--
+-- This function may raise an error if the underlying resource is no longer alive.
+unwrapResource :: Object o => o -> IO WLResource
+unwrapResource o = fetch (toAny o)
+  where fetch obj = readIORef (objResource obj) >>= check
+        check res@(WLResource ptr) | ptr == nullPtr = error "Invalid object handle."
+                                   | otherwise      = pure res
+
+-- | Get the typed object wrapping a Wayland resource.
+--
+-- The object wrapper is stored as a StablePtr in the resource's userdata.
+wrapResource :: Object o => WLResource -> IO o
+wrapResource o = do
+  objPtr <- castPtrToStablePtr <$> wlResourceGetUserData o
+  deRefStablePtr objPtr
+
+-- | Handle the destruction of a Wayland resource.
+--
+-- This will set the object handle's reference to a nullPtr and call the destroy hook.
+destroyResource :: WLResource -> IO ()
+destroyResource res = do
+  objPtr <- castPtrToStablePtr <$> wlResourceGetUserData res
+  obj <- deRefStablePtr objPtr
+  writeIORef (objResource obj) (WLResource nullPtr)
+  freeStablePtr objPtr
+  -- TODO: Prevent destroy hook from being invoked while in the request handler.
+  objDestroyHook obj obj
+
+-- | Create a new Wayland resource and associate it with a typed object wrapper.
+--
+-- This not only creates the object but also attaches a dispatch function to it and updates the destroy callback.
+createResource
+  :: forall o destroyReq. Object o
+  => RequestClass destroyReq
+  => (Request -> IO ()) -- ^ Request handler used for dispatching object requests and the destroy hook.
+  -> NewObject o        -- ^ Handle describing the object to be created
+  -> (o -> destroyReq)  -- ^ Function creating a request dispatched after the object was destroyed.
+  -> ObjectCacheState o -- ^ State monad returning the newly created object.
+createResource handle newObj destroyHook = do
+  existing <- liftIO $ readIORef (newObject newObj)
+  case existing of
+    Just obj -> pure obj
+    Nothing  -> do typeInfo <- resolveTypeInfo (Proxy :: Proxy o)
+                   destroyFunc <- use cacheDestroyFunc
+                   liftIO $ do
+                     client <- unwrapClient (newClient newObj)
+                     res <- wlResourceCreate client (typeInterface typeInfo) (newVersion newObj) (newID newObj)
+                     resRef <- newIORef res
+                     name <- makeStableName resRef
+                     let obj = fromAny $ AnyObject { objName        = name
+                                                   , objResource    = resRef
+                                                   , objDestroyHook = handle . Request . destroyHook . fromAny
+                                                   }
+                     objPtr <- newStablePtr obj
+                     wlResourceSetDispatcher res (typeDispatchFunc typeInfo) nullPtr (castStablePtrToPtr objPtr) destroyFunc
+                     pure obj
+
+-- | Send an event for a typed object.
+--
+-- This function may raise an error if the underlying resource is no longer alive.
+sendResourceEvent :: forall o. Object o => o -> ObjectEvent o -> IO ()
+sendResourceEvent o e = do
+  let paramCount = length $ msgArguments (eventSignature (Proxy :: Proxy o) e)
+  res <- unwrapResource o
+  allocaArray0 paramCount $ \buffer ->
+    let s = ArgumentIterator { _argNext      = buffer
+                             , _argRemaining = paramCount
+                             }
+        handler (opcode, _) = wlResourcePostEventArray res (fromIntegral opcode) buffer
+    in runContT (runStateT (runArgumentIteratorState (marshalEvent (Proxy :: Proxy o) e)) s) handler
+
+-- | Request handler for a typed object.
+--
+-- This provides a WLDispatcherFunc for an object type.
+dispatchResourceRequest :: forall o. Object o => Proxy o -> Ptr () -> WLResource -> Word32 -> Ptr WLMessage -> Ptr WLArgument -> IO CInt
+dispatchResourceRequest _ _ res _ _ _ = do
+  _ :: o <- wrapResource res
+  -- TODO: Handle request
+  pure 0
+
+-- | Resolve a type information for an object type.
+--
+-- This will first attempt to use an existing instance from the 'ObjectCache'. If there is none, it will create a new
+-- structure storing the wl_interface pointer and allocating a function pointer to the typed dispatcher function.
+resolveTypeInfo :: Object o => Proxy o -> ObjectCacheState TypeInfo
+resolveTypeInfo proxy = do
+  existing <- use cacheTypeInfo
+  case M.lookup (typeRep proxy) existing of
+    Just info -> pure info
+    Nothing   -> do interface    <- zoom cacheInterfaces $ resolveInterface (describeInterface proxy)
+                    dispatchFunc <- liftIO $ wrapWLDispatcherFunc (dispatchResourceRequest proxy)
+                    let info = TypeInfo { typeInterface    = interface
+                                        , typeDispatchFunc = dispatchFunc
+                                        }
+                    cacheTypeInfo %= M.insert (typeRep proxy) info
+                    pure info
+
+-- | Resolve the native interface for an object type.
+resolveTypeInterface :: Object o => Proxy o -> ObjectCacheState (Ptr WLInterface)
+resolveTypeInterface proxy = typeInterface <$> resolveTypeInfo proxy
+
+-- | Get the next argument in an argument iterator.
+--
+-- This function may raise an error if there is no more argument remaining.
+advanceIterator :: ArgumentIteratorState r (Ptr WLArgument)
+advanceIterator = do
+  next      <- argNext      <<%= \p -> plusPtr p (sizeOf (undefined :: WLArgument))
+  remaining <- argRemaining <<%= (+(-1))
+  when (remaining == 0) (error "Out of range for argument")
+  pure next
+
+-- | Create an 'ArgumentIteratorState' wrapping a continuation (like alloca).
+liftCont :: ((a -> IO r) -> IO r) -> ArgumentIteratorState r a
+liftCont = ArgumentIteratorState . lift . ContT
+
+instance ArgumentMarshaller (ArgumentIteratorState r) where
+  marshalInt v = do
+    arg <- advanceIterator
+    liftIO $ wlArgumentPokeInt arg (fromIntegral v)
+  marshalUInt v = do
+    arg <- advanceIterator
+    liftIO $ wlArgumentPokeUInt arg (fromIntegral v)
+  marshalFixed v = do
+    arg <- advanceIterator
+    liftIO $ wlArgumentPokeFixed arg (WLFixed (round (v * 256)))
+  marshalFD v = do
+    arg <- advanceIterator
+    liftIO $ wlArgumentPokeFD arg (fromIntegral v)
+  marshalString v = do
+    arg <- advanceIterator
+    str <- liftCont $ withCString v
+    liftIO $ wlArgumentPokeString arg str
+  marshalObject v = do
+    arg <- advanceIterator
+    obj <- liftIO $ unwrapResource v
+    liftIO $ wlArgumentPokeObject arg obj
+  marshalNewID v = do
+    -- TODO
+    undefined
+  marshalArray v = do
+    arg <- advanceIterator
+    let len = fromIntegral $ length v * sizeOf (head v)
+    buf <- liftCont $ withArray v
+    arr <- liftCont $ with $ WLArray { arrSize  = len
+                                     , arrAlloc = len
+                                     , arrData  = castPtr buf
+                                     }
+    liftIO $ wlArgumentPokeArray arg arr
+
+instance ArgumentDemarshaller (ArgumentIteratorState r) where
+  demarshalInt    = fromIntegral   <$> (advanceIterator >>= liftIO . wlArgumentPeekInt)
+  demarshalUInt   = fromIntegral   <$> (advanceIterator >>= liftIO . wlArgumentPeekUInt)
+  demarshalFixed  = wlFixedToFloat <$> (advanceIterator >>= liftIO . wlArgumentPeekFixed)
+  demarshalString = do
+    ptr <- advanceIterator >>= liftIO . wlArgumentPeekString
+    liftIO $ peekCString ptr
+  demarshalObject = do
+    ptr <- advanceIterator >>= liftIO . wlArgumentPeekObject
+    liftIO $ wrapResource ptr
+  demarshalNewID = do
+    -- TODO
+    undefined
+  demarshalArray = do
+    ptr <- advanceIterator >>= liftIO . wlArgumentPeekArray
+    arr <- liftIO $ peek ptr
+    liftIO $ peekArray (fromIntegral (arrSize arr)) (castPtr (arrData arr))
+  demarshalFD = advanceIterator >>= liftIO . wlArgumentPeekFD
diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc
index b01611e..8340efa 100644
--- a/wayland/Wayland/Server/System.hsc
+++ b/wayland/Wayland/Server/System.hsc
@@ -114,6 +114,9 @@ instance Storable WLFixed where
   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
diff --git a/wayland/wayland.cabal b/wayland/wayland.cabal
index ee0f9a9..2708d50 100644
--- a/wayland/wayland.cabal
+++ b/wayland/wayland.cabal
@@ -17,7 +17,11 @@ library
                        microlens-mtl,
                        microlens-th
     default-language:  Haskell2010
-    exposed-modules:   Wayland.Server,
-                       Wayland.Server.System
+    exposed-modules:   Wayland.Server
+    other-modules:     Wayland.Server.System,
+                       Wayland.Server.Interface,
+                       Wayland.Server.Display,
+                       Wayland.Server.Client,
+                       Wayland.Server.Object
     pkgconfig-depends: wayland-server >= 1.23.0
     cpp-options:       -D__attribute__(A)= -D_Nullable= -D_Nonnull= -D_Noreturn=