Handle X events asynchronously

lib/Phi/Phi.hs

@@ -2,7 +2,8 @@
 
 module Phi.Phi ( Phi
                , MessageBus
-               , Message(..)
+               , Message
+               , fromMessage
                , initPhi
                , runPhi
                , sendMessage
@@ -12,11 +13,15 @@ module Phi.Phi ( Phi
 
 import Control.Concurrent.Chan
 import Control.Monad
+import Data.Typeable
 
 data Phi = Phi (Chan Message)
 data MessageBus = MessageBus (Chan Message)
 
-data Message = forall a. Show a => Message a
+data Message = forall a. (Typeable a, Show a) => Message a
+
+fromMessage :: (Typeable a, Show a) => Message -> Maybe a
+fromMessage (Message m) = cast m
 
 initPhi :: IO Phi
 initPhi = liftM Phi newChan
@@ -24,8 +29,8 @@ initPhi = liftM Phi newChan
 runPhi :: Phi -> IO ()
 runPhi (Phi chan) = forever $ readChan chan
 
-sendMessage :: Phi -> Message -> IO ()
-sendMessage (Phi chan) = writeChan chan
+sendMessage :: (Typeable a, Show a) => Phi -> a -> IO ()
+sendMessage (Phi chan) = writeChan chan . Message
 
 getMessageBus :: Phi -> IO MessageBus
 getMessageBus (Phi chan) = liftM MessageBus $ dupChan chan

lib/Phi/Widget.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}
 
-module Phi.Widget ( Message(..)
-                  , Widget(..)
+module Phi.Widget ( Widget(..)
                   , WidgetClass(..)
                   , WidgetState(..)
                   , separator

lib/Phi/X11.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-}
 
 module Phi.X11 ( XConfig(..)
                , defaultXConfig
@@ -16,10 +16,14 @@ import Data.Maybe
 import Data.Bits
 import Data.Char
 
+import Control.Concurrent
+import Control.Concurrent.MVar
 import Control.Monad.State
 import Control.Monad.Reader
 import Control.Monad.Trans
 
+import System.Posix.Types
+
 import Phi.Phi
 import qualified Phi.Types as Phi
 import qualified Phi.Panel as Panel
@@ -45,7 +49,6 @@ data PanelState = PanelState { panelWindow       :: Window
 
 data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
                            , phiXConfig     :: XConfig
-                           , phiDisplay     :: Display
                            , phiAtoms       :: Atoms
                            }
 
@@ -61,14 +64,18 @@ newtype PhiX a = PhiX (StateT PhiState PhiReader a)
 runPhiX :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState)
 runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
 
-liftIOContToPhiX :: ((a -> IO (b, PhiState)) -> IO (b, PhiState)) -> (a -> PhiX b) -> PhiX b
-liftIOContToPhiX f c = do
+forkPhiX :: PhiX () -> PhiX ThreadId
+forkPhiX f = do
   config <- ask
   state <- get
-  (a, state') <- liftIO $ f $ runPhiX config state . c
-  put state'
-  return a
+  liftIO $ forkIO $ (runPhiX config state f >> return ())
 
+withMVarX :: MVar a -> (a -> PhiX b) -> PhiX b
+withMVarX m f = do
+  a <- liftIO $ takeMVar m
+  b <- f a
+  liftIO $ putMVar m a
+  return b
 
 defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
                          }
@@ -77,37 +84,61 @@ defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
 initPhiX :: Phi -> XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
 initPhiX phi xconfig config widgets = do
   disp <- openDisplay []
+
   atoms <- initAtoms disp
   selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
   
-  runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiDisplay = disp, phiAtoms = atoms } PhiState { phiRootPixmap = 0, phiPanels = [] } $ do
-    updateRootPixmap
+  runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiRootPixmap = 0, phiPanels = [] } $ do
+    updateRootPixmap disp
     
     screens <- liftIO $ phiXScreenInfo xconfig disp
-    panels <- mapM (createPanel widgets) screens
+    panels <- mapM (createPanel disp widgets) screens
     forM_ panels $ \panel -> do
-      setPanelProperties panel
+      setPanelProperties disp panel
       liftIO $ mapWindow disp (panelWindow panel)
     
     modify $ \state -> state { phiPanels = panels }
     
-    updatePanels True
+    updatePanels disp True
+    
+    dispvar <- liftIO $ newMVar disp
+    liftIO $ forkIO $ receiveEvents phi dispvar
 
-    liftIOContToPhiX allocaXEvent $ \xevent -> do
-      forever $ do
-        liftIO $ nextEvent disp xevent
-        event <- liftIO $ getEvent xevent
-        
-        case event of
-          ExposeEvent {} -> updatePanels False
-          PropertyEvent {} -> handlePropertyUpdate event
-          _ -> return ()
+    messagebus <- liftIO $ getMessageBus phi
+    forkPhiX $ forever $ do
+      message <- liftIO $ receiveMessage messagebus
+      handleMessage dispvar message
   return ()
 
 
-updatePanels :: Bool -> PhiX ()
-updatePanels redraw = do
-  disp <- asks phiDisplay
+handleMessage :: MVar Display -> Message -> PhiX ()
+handleMessage dispvar m
+  | Just ExposeEvent {} <- fromMessage m = withMVarX dispvar $ \disp -> do
+    updatePanels disp False
+  | Just event@PropertyEvent {} <- fromMessage m = withMVarX dispvar $ \disp -> do
+    handlePropertyUpdate disp event
+handleMessage _ _ = return ()
+
+receiveEvents :: Phi -> MVar Display -> IO ()
+receiveEvents phi dispvar = do
+  connection <- withMVar dispvar $ return . Fd . connectionNumber
+  
+  forever $ allocaXEvent $ \xevent -> do
+    handled <- withMVar dispvar $ \disp -> do
+      pend <- pending disp
+      if pend /= 0 then
+        do
+          liftIO $ nextEvent disp xevent
+          event <- liftIO $ getEvent xevent
+          sendMessage phi event
+
+          return True
+        else return False
+      
+    when (not handled) $ threadWaitRead connection
+
+updatePanels :: Display -> Bool -> PhiX ()
+updatePanels disp redraw = do
   
   rootPixmap <- gets phiRootPixmap
   panels <- gets phiPanels
@@ -135,19 +166,18 @@ updatePanels redraw = do
   modify $ \state -> state { phiPanels = panels' }
 
 
-handlePropertyUpdate :: Event -> PhiX ()
-handlePropertyUpdate PropertyEvent { ev_atom = atom } = do
+handlePropertyUpdate :: Display -> Event -> PhiX ()
+handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do
   atoms <- asks phiAtoms
   panels <- gets phiPanels
 
   when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
-    updateRootPixmap
-    updatePanels True
+    updateRootPixmap disp
+    updatePanels disp True
   
 
-updateRootPixmap :: PhiX ()
-updateRootPixmap = do
-  disp <- asks phiDisplay
+updateRootPixmap :: Display -> PhiX ()
+updateRootPixmap disp = do
   atoms <- asks phiAtoms
   let screen = defaultScreen disp
       rootwin = defaultRootWindow disp
@@ -156,13 +186,12 @@ updateRootPixmap = do
   modify $ \state -> state { phiRootPixmap = pixmap }
 
 
-createPanel :: [Widget.Widget] -> Rectangle -> PhiX PanelState
-createPanel widgets screenRect = do
+createPanel :: Display -> [Widget.Widget] -> Rectangle -> PhiX PanelState
+createPanel disp widgets screenRect = do
   config <- asks phiPanelConfig
-  disp <- asks phiDisplay
   let rect = panelBounds config screenRect
       
-  win <- createPanelWindow rect
+  win <- createPanelWindow disp rect
   gc <- liftIO $ createGC disp win
   
   let screen = defaultScreen disp
@@ -174,9 +203,8 @@ createPanel widgets screenRect = do
   
   return PanelState { panelWindow = win, panelGC = gc, panelPixmap = pixmap, panelSurface = surface, panelArea = rect, panelScreenArea = screenRect, panelWidgetStates = map Widget.createWidgetState widgets }
 
-createPanelWindow :: Rectangle -> PhiX Window
-createPanelWindow rect = do
-  disp <- asks phiDisplay
+createPanelWindow :: Display -> Rectangle -> PhiX Window
+createPanelWindow disp rect = do
   let screen = defaultScreen disp
       depth = defaultDepth disp screen
       visual = defaultVisual disp screen
@@ -192,9 +220,8 @@ createPanelWindow rect = do
     withRectangle rect (createWindow disp rootwin) 0 depth inputOutput visual mask attr
 
 
-setPanelProperties :: PanelState -> PhiX ()
-setPanelProperties panel = do
-  disp <- asks phiDisplay
+setPanelProperties :: Display -> PanelState -> PhiX ()
+setPanelProperties disp panel = do
   atoms <- asks phiAtoms
   liftIO $ do
     storeName disp (panelWindow panel) "Phi"
@@ -221,13 +248,12 @@ setPanelProperties panel = do
     
     Util.setClassHint disp (panelWindow panel) ClassHint { resName = "phi", resClass = "Phi" }
     
-  setStruts panel
+  setStruts disp panel
 
 
-setStruts :: PanelState -> PhiX ()
-setStruts panel = do
+setStruts :: Display -> PanelState -> PhiX ()
+setStruts disp panel = do
   atoms <- asks phiAtoms
-  disp <- asks phiDisplay
   config <- asks phiPanelConfig
   let rootwin = defaultRootWindow disp
       position = Panel.panelPosition config

src/Phi.hs

@@ -10,8 +10,9 @@ import Data.Monoid
 main :: IO ()
 main = do
   phi <- initPhi
-  initPhiX phi defaultXConfig defaultPanelConfig { panelPosition = Bottom, panelSize = 48 }
+  initPhiX phi defaultXConfig defaultPanelConfig { panelPosition = Bottom }
     [border border1 [border border3 [], border border3 []], border border2 []]
+  runPhi phi
     where
       border1 = BorderConfig (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.25, 0.25, 0.25, 0.5) 7 2
       border2 = BorderConfig (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.5, 0.0, 0.25, 0.5) 7 1