diff options
| -rw-r--r-- | src/Main.hs | 4 | ||||
| -rw-r--r-- | src/Types.hs | 6 | ||||
| -rw-r--r-- | src/XUtil.hsc | 21 | ||||
| -rw-r--r-- | src/Xmobar.hs | 50 |
4 files changed, 47 insertions, 34 deletions
diff --git a/src/Main.hs b/src/Main.hs index 5ef5db6..1438ab5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -26,6 +26,7 @@ import Config import XUtil import Data.List (intercalate) +import qualified Data.Map as Map import Paths_xmobar (version) import Data.Version (showVersion) @@ -60,7 +61,8 @@ main = do sig <- setupSignalHandler vars <- mapM (mapM $ startCommand sig) cls (r,w) <- createWin d fs conf - startLoop (XConf d r w fs conf) sig vars + let ic = Map.empty + startLoop (XConf d r w fs ic conf) sig vars -- | Splits the template in its parts splitTemplate :: Config -> [String] diff --git a/src/Types.hs b/src/Types.hs index 3fcc6de..94f2373 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,3 +1,9 @@ module Types where +import Graphics.X11.Xlib data Widget = Text String | Icon String + +data Bitmap = Bitmap { width :: Dimension + , height :: Dimension + , pixmap :: Pixmap + } diff --git a/src/XUtil.hsc b/src/XUtil.hsc index 3c9f799..720e895 100644 --- a/src/XUtil.hsc +++ b/src/XUtil.hsc @@ -17,6 +17,8 @@ module XUtil , initFont , initCoreFont , initUtf8Font + , loadBitmap + , drawBitmap , textExtents , textWidth , printString @@ -73,11 +75,6 @@ hGetLineSafe = UTF8.hGetLine hGetLineSafe = hGetLine #endif -data Bitmap = Bitmap { width :: Dimension - , height :: Dimension - , pixmap :: Pixmap - } - -- Hide the Core Font/Xft switching here data XFont = Core FontStruct | Utf8 FontSet @@ -181,30 +178,22 @@ drawBitmap d p _ gc fc bc x y i = do io $ copyPlane d (pixmap i) p gc 0 0 (width i) (height i) x (y - (fi $ height i)) 1 printString :: Display -> Drawable -> XFont -> GC -> String -> String - -> Position -> Position -> Widget -> IO () -printString d p fs gc fc bc x y w = do - case w of - (Text s) -> printString' d p fs gc fc bc x y s - (Icon i) -> do bitmap <- loadBitmap d p i - forM_ bitmap $ drawBitmap d p fs gc fc bc x y - -printString' :: Display -> Drawable -> XFont -> GC -> String -> String -> Position -> Position -> String -> IO () -printString' d p (Core fs) gc fc bc x y s = do +printString d p (Core fs) gc fc bc x y s = do setFont d gc $ fontFromFontStruct fs withColors d [fc, bc] $ \[fc', bc'] -> do setForeground d gc fc' setBackground d gc bc' drawImageString d p gc x y s -printString' d p (Utf8 fs) gc fc bc x y s = +printString d p (Utf8 fs) gc fc bc x y s = withColors d [fc, bc] $ \[fc', bc'] -> do setForeground d gc fc' setBackground d gc bc' io $ wcDrawImageString d p fs gc x y s #ifdef XFT -printString' dpy drw fs@(Xft font) _ fc bc x y s = do +printString dpy drw fs@(Xft font) _ fc bc x y s = do (a,d) <- textExtents fs s gi <- xftTxtExtents dpy font s withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' -> diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 7730620..b7355c4 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -23,13 +23,13 @@ module Xmobar , startCommand -- * Window Management -- $window - , createWin, updateWin + , createWin -- * Printing -- $print , drawInWin, printStrings ) where -import Prelude +import Prelude hiding (lookup) import Graphics.X11.Xlib hiding (textExtents, textWidth) import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama @@ -41,12 +41,14 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Exception (handle, SomeException(..)) import Data.Bits +import Data.Map hiding (foldr, map, filter) import Config import Parsers import Commands import Runnable import Signal +import Types import Window import XUtil import ColorCache @@ -72,6 +74,7 @@ data XConf = , rect :: Rectangle , window :: Window , fontS :: XFont + , iconS :: Map FilePath Bitmap , config :: Config } @@ -81,7 +84,7 @@ runX xc f = runReaderT f xc -- | Starts the main event loop and threads startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO () -startLoop xcfg@(XConf _ _ w _ _) sig vs = do +startLoop xcfg@(XConf _ _ w _ _ _) sig vs = do #ifdef XFT xftInitFtLibrary #endif @@ -98,7 +101,7 @@ startLoop xcfg@(XConf _ _ w _ _) sig vs = do eventLoop tv xcfg sig where handler thing (SomeException _) = - putStrLn ("Thread " ++ thing ++ " failed") >> return () + void $ putStrLn ("Thread " ++ thing ++ " failed") -- Reacts on events from X eventer signal = allocaXEvent $ \e -> do @@ -139,12 +142,14 @@ checker tvar ov vs signal = do -- | Continuously wait for a signal from a thread or a interrupt handler eventLoop :: TVar [String] -> XConf -> TMVar SignalType -> IO () -eventLoop tv xc@(XConf d r w fs cfg) signal = do +eventLoop tv xc@(XConf d r w fs is cfg) signal = do typ <- atomically $ takeTMVar signal case typ of Wakeup -> do - runX xc (updateWin tv) - eventLoop tv xc signal + str <- updateString cfg tv + xc' <- updateCache d w is str >>= \c -> return xc { iconS = c } + runX xc' $ drawInWin r str + eventLoop tv xc' signal Reposition -> reposWindow cfg @@ -187,7 +192,7 @@ eventLoop tv xc@(XConf d r w fs cfg) signal = do reposWindow rcfg = do r' <- repositionWin d w fs rcfg - eventLoop tv (XConf d r' w fs rcfg) signal + eventLoop tv (XConf d r' w fs is rcfg) signal updateConfigPosition ocfg = case position ocfg of @@ -219,14 +224,23 @@ startCommand sig (com,s,ss) return (Just h,var) where is = s ++ "Updating..." ++ ss -updateWin :: TVar [String] -> X () -updateWin v = do - xc <- ask - s <- io $ atomically $ readTVar v - let (conf,rec) = (config &&& rect) xc - l:c:r:_ = s ++ repeat "" - ps <- io $ mapM (parseString conf) [l, c, r] - drawInWin rec ps +updateString :: Config -> TVar [String] -> IO [[(Widget, String)]] +updateString conf v = do + s <- atomically $ readTVar v + let l:c:r:_ = s ++ repeat "" + io $ mapM (parseString conf) [l, c, r] + +updateCache :: Display -> Window -> Map FilePath Bitmap -> [[(Widget, String)]] -> IO (Map FilePath Bitmap) +updateCache dpy win cache ps = do + let paths = map (\(Icon p, _) -> p) . concatMap (filter icons) $ ps + icons (Icon _, _) = True + icons _ = False + foldM (\m path -> if member path m + then return m + else do bitmap <- io $ loadBitmap dpy win path + case bitmap of + Nothing -> return m + Just bmap -> return $ insert path bmap m) cache paths -- $print @@ -283,5 +297,7 @@ printStrings dr gc fontst offs a sl@((s,c,l):xs) = do (fc,bc) = case break (==',') c of (f,',':b) -> (f, b ) (f, _) -> (f, bgColor conf) - io $ printString d dr fontst gc fc bc offset valign s + case s of + (Text t) -> io $ printString d dr fontst gc fc bc offset valign t + (Icon p) -> io $ maybe (return ()) (drawBitmap d dr fontst gc fc bc offset valign) (lookup p (iconS r)) printStrings dr gc fontst (offs + l) a xs |