Now Xmobar uses STM concurrency

Now every time a TVar is updated the output window is redrawn.

darcs-hash:20071002114538-d6583-9bc6f89b95b5e66049157d261ed2205a8fae49d9.gz

1 files changed, 61 insertions, 65 deletions

diff --git a/Xmobar.hs b/Xmobar.hs
index f8cf1a2..f291b3d 100644
--- a/Xmobar.hs
+++ b/Xmobar.hs
@@ -26,8 +26,7 @@ module Xmobar (-- * Main Stuff
               , printStrings
               -- * Program Execution
               -- $commands
-              , execCommand
-              , readVariables
+              , startCommand
               -- * Unmamaged Windows
               -- $unmanwin
               , mkUnmanagedWindow
@@ -44,8 +43,8 @@ import Graphics.X11.Xlib.Event
 import Control.Monad.State
 import Control.Monad.Reader
 import Control.Concurrent
+import Control.Concurrent.STM
 import Control.Exception
-
 import System.Posix.Types (Fd(..))
 
 import Config
@@ -65,44 +64,59 @@ newtype Xbar a = X (ReaderT Config (StateT XState IO) a)
 data XState = 
     XState { display :: Display
            , window  :: Window
-           , vars    :: [(Maybe ThreadId, MVar String)]
            }
 
 -- | We use get to get the state and ask to get the configuration: whis way 
 -- functions requires less arguments.
-runXbar :: Config -> [(Maybe ThreadId, MVar String)] -> Display -> Window -> Xbar () -> IO ()
-runXbar c v d w (X f) = 
-    do runStateT (runReaderT f c) (XState d w v)
+runXbar :: Config -> Display -> Window -> Xbar () -> IO ()
+runXbar c d w (X f) = 
+    do runStateT (runReaderT f c) (XState d w)
        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 :: Config -> [(Maybe ThreadId, MVar String)] -> Display -> Window -> IO ()
+eventLoop :: Config -> [(Maybe ThreadId, TVar String)] -> Display -> Window -> IO ()
 eventLoop c v d w = do
-    t <- forkIO (block go)
-    timer t
+    tv <- atomically $ newTVar []
+    t    <- forkIO (block $ go tv)
+    timer t tv
  where
-    -- interrupt the drawing thread every so often
-    timer t = do
-        tenthSeconds (refresh c)
-        throwTo t (ErrorCall "Xmobar.eventLoop: yield")
-        timer t
+    -- interrupt the drawing thread every time a var is updated
+    timer t tvar = do
+      nval <- atomically $ do
+              ov <- readTVar tvar
+              nv <- mapM readTVar (map snd v)
+              if concat nv == ov then retry else return (concat nv)
+      atomically $ writeTVar tvar nval
+      threadDelay 1000
+      throwTo t (ErrorCall "Xmobar.eventLoop: yield")
+      timer t tvar
     -- 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
+    go tvar = do
+      runXbar c d w (updateWin tvar)
+      catch (unblock $ allocaXEvent $ nextEvent' d) (const $ return ())
+      go tvar
+
+updateWin :: TVar String -> Xbar ()
+updateWin v =
+    do i  <- io $ atomically $ readTVar v
+       c  <- ask
+       ps <- io $ parseString c i
+       drawInWin ps
+
+-- $commands 
+
+-- | Runs a command as an independent thread and returns its thread id
+-- and the TVar the command will be writing to.
+startCommand :: (Runnable,String,String) -> IO (Maybe ThreadId, TVar String)
+startCommand (com,s,ss)
+    | alias com == ""  = do var <- atomically $ newTVar is
+                            atomically $ writeTVar var ("Could not parse the template")
+                            return (Nothing,var)
+    | otherwise        = do var <- atomically $ newTVar is
+                            let cb str = atomically $ writeTVar var (s ++ str ++ ss)
+                            h <- forkIO $ start com cb
+                            return (Just h,var)
+    where is = "Updating... "
 
 -- | The function to create the initial window
 createWin :: Config -> IO (Display, Window)
@@ -111,22 +125,14 @@ createWin config =
      let dflt = defaultScreen dpy
      rootw <- rootWindow dpy dflt
      win   <- mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw 
-            (fi $ xPos config) 
-            (fi $ yPos config) 
-            (fi $ width config) 
+            (fi $ xPos   config) 
+            (fi $ yPos   config) 
+            (fi $ width  config) 
             (fi $ height config)
      selectInput dpy win exposureMask
      mapWindow   dpy win
      return (dpy,win)
 
-updateWin :: Xbar ()
-updateWin =
-    do c  <- ask
-       s  <- get
-       i  <- io $ readVariables (vars s)
-       ps <- io $ parseString c i
-       drawInWin ps
-
 -- $print
 
 -- | Draws in and updates the window
@@ -173,7 +179,7 @@ printStrings :: Drawable
 printStrings _ _ _ _ [] = return ()
 printStrings d gc fontst offs sl@((s,c,l):xs) =
     do config <- ask
-       st <- get
+       st     <- get
        let (_,asc,_,_) = textExtents fontst s
            totSLen     = foldr (\(_,_,len) -> (+) len) 0 sl
            valign      = (fi (height config) + fi asc) `div` 2
@@ -190,28 +196,6 @@ printStrings d gc fontst offs sl@((s,c,l):xs) =
        io $ drawImageString (display st) d gc offset valign s
        printStrings d gc fontst (offs + l) xs
 
--- $commands
-
--- | Runs a command as an independent thread and returns its thread id
--- and the MVar the command will be writing to.
-execCommand :: (Runnable,String,String) -> IO (Maybe ThreadId, MVar String)
-execCommand (com,s,ss)
-    | alias com == ""  = do var <- newMVar "Updating..."
-                            modifyMVar_ var (const $ return $ "Could not parse the template")
-                            return (Nothing,var)
-    | otherwise        = do var <- newMVar "Updating..."
-                            let cb str = modifyMVar_ var (\_ -> return $ s ++ str ++ ss)
-                            h <- forkIO $ start com cb
-                            return (Just h,var)
-
--- | Reads MVars set by 'runCommandLoop'
-readVariables :: [(Maybe ThreadId, MVar String)] -> IO String
-readVariables [] = return ""
-readVariables ((_,v):xs) =
-    do f  <- readMVar v
-       fs <- readVariables xs
-       return $! f ++ fs
-
 {- $unmanwin
 
 This is a way to create unmamaged window. It was a mistery in Haskell. 
@@ -253,6 +237,18 @@ initColor' :: Display -> String -> IO Pixel
 initColor' dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c
     where colormap = defaultColormap dpy (defaultScreen dpy)
 
+-- | 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
+
 -- | Short-hand for lifting in the IO monad
 io :: IO a -> Xbar a
 io = liftIO