wrap interfaces

2 files changed, 132 insertions, 43 deletions

diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
index 76b9ff4..b0c5b89 100644
--- a/wayland/Wayland/Server.hs
+++ b/wayland/Wayland/Server.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Wayland.Server
   ( Request(..)
@@ -29,27 +30,25 @@ module Wayland.Server
   , requestTermination
   ) where
 
-import Data.Typeable (Typeable, Proxy, cast)
+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 Wayland.Server.System
+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)
+import Foreign.C (peekCString, newCString)
 import Foreign.C.Types (CInt)
-import Foreign (nullPtr)
+import Foreign (Ptr, nullPtr, new)
 import Data.IORef (IORef, newIORef, writeIORef, readIORef)
 import Control.Monad.Reader (ReaderT, MonadReader (..), runReaderT)
 import Control.Exception (bracket)
 import Data.Functor (($>))
-
-type RequestHandler s = Request -> DisplayM s ()
-type EventLoopHandler = Request -> IO ()
-
-data Display
-  = Display { display         :: !WLDisplay
-            , activeEventLoop :: !(IORef (Maybe EventLoopHandler))
-            }
+import Control.Monad (when)
+import Data.Maybe (isJust)
+import qualified Data.Map as M
+import Foreign.Marshal (newArray)
 
 data Global = Global
 
@@ -59,25 +58,26 @@ newtype ObjectID = ObjectID String
 data Nullability
   = AllowNull
   | NotNull
+  deriving (Show, Eq, Ord)
 
 data ArgumentDesc
   = ArgumentInt
   | ArgumentUInt
   | ArgumentFixed
   | ArgumentString !Nullability
-  | ArgumentObject !Nullability
-  | ArgumentNewID
+  | ArgumentObject !Nullability !InterfaceDesc
+  | ArgumentNewID  !InterfaceDesc
   | ArgumentArray
   | ArgumentFD
+  deriving (Show, Eq, Ord)
 
 data MessageDesc
   = MessageDesc { msgName              :: !String
                 , msgSignature         :: ![ArgumentDesc]
                 , msgSince             :: !Int
                 , msgIsDestructor      :: !Bool
-                , msgCreatedInterface  :: !(Maybe InterfaceDesc)
-                , msgArgumentInterface :: ![InterfaceDesc]
                 }
+  deriving (Show, Eq, Ord)
 
 data InterfaceDesc
   = InterfaceDesc { ifName     :: !String
@@ -85,62 +85,92 @@ data InterfaceDesc
                   , ifRequests :: ![MessageDesc]
                   , ifEvents   :: ![MessageDesc]
                   }
+  deriving (Show, Eq, Ord)
+
+class (Typeable r, Show r) => RequestClass r 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)
 
-class ResourceClass r where
+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 => ResourceClass r where
   type ResourceRequest r :: Type
   type ResourceEvent   r :: Type
-  objectID  :: r -> ObjectID
+  objectID  :: r       -> ObjectID
   interface :: Proxy r -> InterfaceDesc
 
-class (Typeable r, Show r) => RequestClass r where
-
-data Request = forall a. RequestClass a => Request a
 
 instance Show Request where
   show (Request r) = show r
 
-newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (ReaderT Display IO) a }
-  deriving (Functor, Applicative, Monad, MonadIO, MonadState s)
 
-type instance Zoomed (DisplayM s) = Zoomed (StateT s (ReaderT Display IO))
+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 ask
+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 wlDisplayCreate wlDisplayDestroy $ \sysDisp -> do
+withDisplay initialState f = bracket Sys.wlDisplayCreate Sys.wlDisplayDestroy $ \sysDisp -> do
   eventLoop <- newIORef Nothing
   let disp = Display { display         = sysDisp
-                     , activeEventLoop = eventLoop }
-  runReaderT (runStateT (runDisplayM f) initialState) disp
+                     , 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 $ wlDisplayAddSocketAuto (display disp)
+  name <- liftIO $ Sys.wlDisplayAddSocketAuto (display disp)
   liftIO $ peekCString name
 
 processRequests :: RequestHandler s -> DisplayM s ()
 processRequests h = do
   disp <- getDisplay
   stateBefore <- get
-  stateRef <- liftIO $ newIORef stateBefore
+  displayStateBefore <- liftDisplayState get
+  stateRef <- liftIO $ newIORef (stateBefore, displayStateBefore)
   let handler :: Request -> IO ()
       handler r = do
-        s <- readIORef stateRef
-        (_, s') <- runReaderT (runStateT (runDisplayM (h r)) s) disp
-        writeIORef stateRef s'
-        pure ()
-  liftIO $ writeIORef (activeEventLoop disp) (Just handler)
-  liftIO $ wlDisplayRun (display disp)
-  stateAfter <- liftIO $ readIORef stateRef
+        (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
 
 sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
 sendEvent _ _ = undefined
@@ -161,18 +191,75 @@ runRequest :: Display -> Request -> IO ()
 runRequest disp r = do
   loop <- readIORef (activeEventLoop disp)
   case loop of
-    Just handler -> handler r
+    Just handler -> handleEvent handler r
     Nothing      -> putStrLn $ "Lost request because no event loop is active: " ++ show r
 
 registerSignalEvent :: RequestClass req => req -> CInt -> DisplayM s ()
 registerSignalEvent r sig = do
   disp <- getDisplay
-  loop <- liftIO $ wlDisplayGetEventLoop (display disp)
-  func <- liftIO $ wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0
-  _ <- liftIO $ wlEventLoopAddSignal loop sig func nullPtr
-  pure ()
+  liftIO $ do
+    loop <- Sys.wlDisplayGetEventLoop (display disp)
+    func <- Sys.wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0
+    _ <- Sys.wlEventLoopAddSignal loop sig func nullPtr
+    -- TODO: Free func
+    pure ()
 
 requestTermination :: DisplayM s ()
 requestTermination = do
   disp <- getDisplay
-  liftIO $ wlDisplayTerminate (display disp)
+  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
diff --git a/wayland/Wayland/Server/System.hsc b/wayland/Wayland/Server/System.hsc
index 60940ce..f758a65 100644
--- a/wayland/Wayland/Server/System.hsc
+++ b/wayland/Wayland/Server/System.hsc
@@ -12,6 +12,7 @@ data WLMessage
               , msgSignature :: CString
               , msgTypes     :: Ptr (Ptr WLInterface)
               }
+  deriving (Show)
 
 data WLInterface
   = WLInterface { ifName        :: CString
@@ -21,6 +22,7 @@ data WLInterface
                 , ifEventCount  :: CInt
                 , ifEvents      :: Ptr WLMessage
                 }
+  deriving (Show)
 
 newtype WLDisplay     = WLDisplay     (Ptr WLDisplay)
 newtype WLEventLoop   = WLEventLoop   (Ptr WLEventLoop)