From 7235e59441c94580e99d50774629579fe54c6b1a Mon Sep 17 00:00:00 2001
From: Spencer Janssen <sjanssen@cse.unl.edu>
Date: Wed, 18 Jul 2007 00:51:31 +0200
Subject: Use asynchronous exceptions to obviate the need for forkOS and
 threaded

darcs-hash:20070717225131-a5988-1f5e0cb3c8373b5eb6f7e87496110409380ded23.gz
---
 Main.hs      |  3 ++-
 Xmobar.hs    | 52 ++++++++++++++++++++++++++++++++--------------------
 xmobar.cabal |  3 +--
 3 files changed, 35 insertions(+), 23 deletions(-)

diff --git a/Main.hs b/Main.hs
index c83b1f5..55e5487 100644
--- a/Main.hs
+++ b/Main.hs
@@ -37,7 +37,8 @@ main =
        cl <- parseTemplate config (template config)
        var <- execCommands config cl
        (d,w) <- createWin config
-       runXbar config var d w eventLoop
+       eventLoop config var d w
+       return ()
 
 -- | Reads the configuration files or quits with an error
 readConfig :: FilePath -> IO Config
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 ()
diff --git a/xmobar.cabal b/xmobar.cabal
index 0202ab6..89d79c2 100644
--- a/xmobar.cabal
+++ b/xmobar.cabal
@@ -12,8 +12,7 @@ license:            BSD3
 license-file:       LICENSE
 author:             Andrea Rossato
 maintainer:         andrea.rossato@unibz.it
-build-depends:      base>=2.0, X11>=1.2.1, mtl>=1.0, unix>=1.0, parsec>=2.0, filepath>=1.0, 
-		    X11-extras>=0.2
+build-depends:      base>=2.0, X11>=1.2.1, mtl>=1.0, unix>=1.0, parsec>=2.0, filepath>=1.0
 
 executable:         xmobar
 main-is:            Main.hs
-- 
cgit v1.2.3