1 files changed, 71 insertions, 20 deletions

diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
index 0b0b6ea..76b9ff4 100644
--- a/wayland/Wayland/Server.hs
+++ b/wayland/Wayland/Server.hs
@@ -11,6 +11,7 @@ module Wayland.Server
   , Global
   , DisplayM(..)
   , ResourceClass(..)
+  , RequestClass
   , InterfaceDesc(..)
   , MessageDesc(..)
   , ArgumentDesc(..)
@@ -24,19 +25,31 @@ module Wayland.Server
   , destroyResource
   , registerGlobal
   , unregisterGlobal
+  , registerSignalEvent
+  , requestTermination
   ) where
 
 import Data.Typeable (Typeable, Proxy, cast)
 import Data.Kind (Type)
-import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT, gets)
+import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT)
 import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
 import Wayland.Server.System
 import Control.Monad.Trans (MonadTrans(..))
 import Foreign.C (peekCString)
+import Foreign.C.Types (CInt)
+import Foreign (nullPtr)
+import Data.IORef (IORef, newIORef, writeIORef, readIORef)
+import Control.Monad.Reader (ReaderT, MonadReader (..), runReaderT)
+import Control.Exception (bracket)
+import Data.Functor (($>))
 
-data DisplayState
-  = DisplayState { display :: WLDisplay
-                 }
+type RequestHandler s = Request -> DisplayM s ()
+type EventLoopHandler = Request -> IO ()
+
+data Display
+  = Display { display         :: !WLDisplay
+            , activeEventLoop :: !(IORef (Maybe EventLoopHandler))
+            }
 
 data Global = Global
 
@@ -79,37 +92,55 @@ class ResourceClass r where
   objectID  :: r -> ObjectID
   interface :: Proxy r -> InterfaceDesc
 
-data Request = forall a. Typeable a => Request a
+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 IO) 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 (StateT DisplayState IO))
+type instance Zoomed (DisplayM s) = Zoomed (StateT s (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
+
 fromRequest :: Typeable a => Request -> Maybe a
 fromRequest (Request x) = cast x
 
 withDisplay :: s -> DisplayM s a -> IO (a, s)
-withDisplay initialState f = do
-  disp <- wlDisplayCreate
-  let dispState = DisplayState { display = disp }
-  (res, _) <-runStateT (runStateT (runDisplayM f) initialState) dispState
-  wlDisplayDestroy disp
-  return res
+withDisplay initialState f = bracket wlDisplayCreate wlDisplayDestroy $ \sysDisp -> do
+  eventLoop <- newIORef Nothing
+  let disp = Display { display         = sysDisp
+                     , activeEventLoop = eventLoop }
+  runReaderT (runStateT (runDisplayM f) initialState) disp
 
 bindSocket :: DisplayM s String
 bindSocket = do
-  disp <- DisplayM $ lift $ gets display
-  name <- liftIO $ wlDisplayAddSocketAuto disp
+  disp <- getDisplay
+  name <- liftIO $ wlDisplayAddSocketAuto (display disp)
   liftIO $ peekCString name
 
-processRequests :: (Request -> DisplayM s ()) -> DisplayM s ()
-processRequests _ = do
-  disp <- DisplayM $ lift $ gets display
-  liftIO $ wlDisplayRun disp
+processRequests :: RequestHandler s -> DisplayM s ()
+processRequests h = do
+  disp <- getDisplay
+  stateBefore <- get
+  stateRef <- liftIO $ newIORef stateBefore
+  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
+  put stateAfter
 
 sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
 sendEvent _ _ = undefined
@@ -120,8 +151,28 @@ flushEvents = undefined
 destroyResource :: ResourceClass r => r -> DisplayM s ()
 destroyResource _ = undefined
 
-registerGlobal :: ResourceClass r => Typeable req => (r -> req) -> DisplayM s Global
+registerGlobal :: ResourceClass r => RequestClass req => (r -> req) -> DisplayM s Global
 registerGlobal _ = pure Global
 
 unregisterGlobal :: Global -> DisplayM s ()
 unregisterGlobal _ = pure ()
+
+runRequest :: Display -> Request -> IO ()
+runRequest disp r = do
+  loop <- readIORef (activeEventLoop disp)
+  case loop of
+    Just handler -> 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 ()
+
+requestTermination :: DisplayM s ()
+requestTermination = do
+  disp <- getDisplay
+  liftIO $ wlDisplayTerminate (display disp)