diff options
| -rw-r--r-- | Xmobar.hs | 126 |
1 files changed, 61 insertions, 65 deletions
@@ -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 |