Use asynchronous exceptions to obviate the need for forkOS and threaded

darcs-hash:20070717225131-a5988-1f5e0cb3c8373b5eb6f7e87496110409380ded23.gz

1 files changed, 32 insertions, 20 deletions

diff --git a/Xmobar.hs b/Xmobar.hs
index 4da9486..13109b0 100644
--- a/Xmobar.hs
+++ b/Xmobar.hs
@@ -20,7 +20,6 @@ module Xmobar (-- * Main Stuff
               , eventLoop
               , createWin
               , updateWin
-              , sendUpdateEvent
               -- * Printing
               -- $print
               , drawInWin
@@ -39,14 +38,17 @@ module Xmobar (-- * Main Stuff
               , io
               ) where
 
+import Prelude hiding (catch)
 import Graphics.X11.Xlib
 import Graphics.X11.Xlib.Misc
 import Graphics.X11.Xlib.Event
-import Graphics.X11.Xlib.Extras
 
 import Control.Monad.State
 import Control.Monad.Reader
 import Control.Concurrent
+import Control.Exception
+
+import System.Posix.Types (Fd(..))
 
 import Config
 import Parsers
@@ -75,16 +77,34 @@ runXbar c v d w (X f) =
     do runStateT (runReaderT f c) (XState d w v)
        return ()
 
+-- | A version of nextEvent that does not block in foreign calls.
+nextEvent' :: Display -> XEventPtr -> IO ()
+nextEvent' d p = do
+    pend <- pending d
+    if pend /= 0
+        then nextEvent d p
+        else do
+            threadWaitRead (Fd fd)
+            nextEvent' d p
+ where
+    fd = connectionNumber d
+
 -- | The event loop
-eventLoop :: Xbar ()
-eventLoop =
-    do c <- ask
-       s <- get
-       io $ forkOS $ sendUpdateEvent (display s) (window s) (refresh c)
-       io $ allocaXEvent $ \e ->
-           nextEvent (display s) e
-       updateWin
-       eventLoop
+eventLoop :: Config -> [(ThreadId, MVar String)] -> Display -> Window -> IO ()
+eventLoop c v d w = do
+    t <- forkIO (block go)
+    timer t
+ where
+    -- interrupt the drawing thread every so often
+    timer t = do
+        tenthSeconds (refresh c)
+        throwTo t (ErrorCall "Xmobar.eventLoop: yield")
+        timer t
+    -- Continuously wait for a timer interrupt or an expose event
+    go = do
+        runXbar c v d w updateWin
+        catch (unblock $ allocaXEvent $ nextEvent' d) (const $ return ())
+        go
 
 -- | The function to create the initial window
 createWin :: Config -> IO (Display, Window)
@@ -101,14 +121,6 @@ createWin config =
      mapWindow dpy win
      return (dpy,win)
 
-sendUpdateEvent :: Display -> Window -> Int -> IO ()
-sendUpdateEvent dpy w d = 
-    do tenthSeconds d
-       allocaXEvent $ \e -> do
-         setEventType e expose
-         sendEvent dpy w False noEventMask e 
-       sync dpy False
-
 updateWin :: Xbar ()
 updateWin =
     do c <- ask
@@ -190,7 +202,7 @@ execCommands c xs = mapM (execCommand c) xs
 execCommand :: Config -> (Runnable,String,String) -> IO (ThreadId, MVar String)
 execCommand c com = 
     do var <- newMVar "Updating..."
-       h <- forkOS $ runCommandLoop var c com
+       h <- forkIO $ runCommandLoop var c com
        return (h,var)
 
 runCommandLoop :: MVar String -> Config -> (Runnable,String,String) -> IO ()