wip refactoring

1 files changed, 34 insertions, 416 deletions

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