summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorAndrea Rossato <andrea.rossato@ing.unitn.it>2007-10-02 13:45:38 +0200
committerAndrea Rossato <andrea.rossato@ing.unitn.it>2007-10-02 13:45:38 +0200
commit8f0200c6d6aed386200b41145ff3521c990e5f59 (patch)
treed33e53b5e2f5ea6f720f68ac386372c3674e3b4e
parent9e24f1964ebd6c642ebfc68f2932c363c1ec81e6 (diff)
downloadxmobar-8f0200c6d6aed386200b41145ff3521c990e5f59.tar.gz
xmobar-8f0200c6d6aed386200b41145ff3521c990e5f59.tar.bz2
Now Xmobar uses STM concurrency
Now every time a TVar is updated the output window is redrawn. darcs-hash:20071002114538-d6583-9bc6f89b95b5e66049157d261ed2205a8fae49d9.gz
-rw-r--r--Xmobar.hs126
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