summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar.hs
diff options
context:
space:
mode:
authorAlexander Polakov <plhk@sdf.org>2013-02-02 04:59:36 +0400
committerAlexander Polakov <plhk@sdf.org>2013-02-03 15:41:09 +0400
commit7160bbed9870247268469330c18a5e7708eb12a3 (patch)
treee29110929981f40c825ee09f2786897b1d2d9670 /src/Xmobar.hs
parent5c6cb344e0221b20b38ce1decf03029e9051417b (diff)
downloadxmobar-7160bbed9870247268469330c18a5e7708eb12a3.tar.gz
xmobar-7160bbed9870247268469330c18a5e7708eb12a3.tar.bz2
Implement icon caching
Diffstat (limited to 'src/Xmobar.hs')
-rw-r--r--src/Xmobar.hs50
1 files changed, 33 insertions, 17 deletions
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