summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--src/Main.hs4
-rw-r--r--src/Types.hs6
-rw-r--r--src/XUtil.hsc21
-rw-r--r--src/Xmobar.hs50
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