summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--XUtil.hsc68
-rw-r--r--Xmobar.hs38
2 files changed, 60 insertions, 46 deletions
diff --git a/XUtil.hsc b/XUtil.hsc
index e6de33c..fc0e7b9 100644
--- a/XUtil.hsc
+++ b/XUtil.hsc
@@ -27,6 +27,7 @@ module XUtil
, hGetLineSafe
, io
, fi
+ , withColors
) where
import Control.Concurrent
@@ -147,42 +148,55 @@ printString :: Display -> Drawable -> XFont -> GC -> String -> String
-> Position -> Position -> String -> IO ()
printString d p (Core fs) gc fc bc x y s = do
setFont d gc $ fontFromFontStruct fs
- [fc',bc'] <- mapM (initColor d) [fc,bc]
- 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 = do
- [fc',bc'] <- mapM (initColor d) [fc,bc]
- setForeground d gc fc'
- setBackground d gc bc'
- io $ wcDrawImageString d p fs gc x y s
+ 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 =
+ 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) gc fc bc x y s = do
let screen = defaultScreenOfDisplay dpy
colormap = defaultColormapOfScreen screen
visual = defaultVisualOfScreen screen
- bcolor <- initColor dpy bc
- (a,d) <- textExtents fs s
- gi <- xftTextExtents dpy font s
- setForeground dpy gc bcolor
- fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))
- (y - fi a)
- (fi $ xglyphinfo_xOff gi)
- (fi $ a + d)
- withXftDraw dpy drw visual colormap $
- \draw -> withXftColorName dpy visual colormap fc $
- \color -> xftDrawString draw color font x y s
+ withColors d [bc] $ \[bcolor] -> do
+ (a,d) <- textExtents fs s
+ gi <- xftTextExtents dpy font s
+ setForeground dpy gc bcolor
+ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))
+ (y - fi a)
+ (fi $ xglyphinfo_xOff gi)
+ (fi $ a + d)
+ withXftDraw dpy drw visual colormap $
+ \draw -> withXftColorName dpy visual colormap fc $
+ \color -> xftDrawString draw color font x y s
#endif
-- | Get the Pixel value for a named color: if an invalid name is
-- given the black pixel will be returned.
-initColor :: Display -> String -> IO Pixel
-initColor dpy c =
- catch (initColor' dpy c) (const . return . blackPixel dpy $ (defaultScreen dpy))
-
-initColor' :: Display -> String -> IO Pixel
-initColor' dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c
- where colormap = defaultColormap dpy (defaultScreen dpy)
+initColor :: Display -> String -> IO (Bool, Pixel)
+initColor dpy c = (initColor' dpy c) `catch`
+ (const $ return (False, blackPixel dpy $ defaultScreen dpy))
+
+initColor' :: Display -> String -> IO (Bool, Pixel)
+initColor' dpy c = do
+ (c', _) <- allocNamedColor dpy colormap c
+ return (True, color_pixel c')
+ where colormap = defaultColormap dpy (defaultScreen dpy)
+
+withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a
+withColors d cs f = do
+ ps <- mapM (io . initColor d) cs
+ r <- f $ map snd ps
+ io $ freeColors d cmap (map snd $ filter fst ps) 0
+ return r
+ where
+ cmap = defaultColormap d (defaultScreen d)
-- | Creates a window with the attribute override_redirect set to True.
-- Windows Managers should not touch this kind of windows.
diff --git a/Xmobar.hs b/Xmobar.hs
index 823abc4..d3c252d 100644
--- a/Xmobar.hs
+++ b/Xmobar.hs
@@ -233,25 +233,25 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
let (c,d ) = (config &&& display) r
(w,fs) = (window &&& fontS ) r
strLn = io . mapM (\(s,cl) -> textWidth d fs s >>= \tw -> return (s,cl,fi tw))
- bgcolor <- io $ initColor d $ bgColor c
- gc <- io $ createGC d w
- -- create a pixmap to write to and fill it with a rectangle
- p <- io $ createPixmap d w wid ht
- (defaultDepthOfScreen (defaultScreenOfDisplay d))
- -- the fgcolor of the rectangle will be the bgcolor of the window
- io $ setForeground d gc bgcolor
- io $ fillRectangle d p gc 0 0 wid ht
- -- write to the pixmap the new string
- printStrings p gc fs 1 L =<< strLn left
- printStrings p gc fs 1 R =<< strLn right
- printStrings p gc fs 1 C =<< strLn center
- -- copy the pixmap with the new string to the window
- io $ copyArea d p w gc 0 0 wid ht 0 0
- -- free up everything (we do not want to leak memory!)
- io $ freeGC d gc
- io $ freePixmap d p
- -- resync
- io $ sync d True
+ withColors d [bgColor c] $ \[bgcolor] -> do
+ gc <- io $ createGC d w
+ -- create a pixmap to write to and fill it with a rectangle
+ p <- io $ createPixmap d w wid ht
+ (defaultDepthOfScreen (defaultScreenOfDisplay d))
+ -- the fgcolor of the rectangle will be the bgcolor of the window
+ io $ setForeground d gc bgcolor
+ io $ fillRectangle d p gc 0 0 wid ht
+ -- write to the pixmap the new string
+ printStrings p gc fs 1 L =<< strLn left
+ printStrings p gc fs 1 R =<< strLn right
+ printStrings p gc fs 1 C =<< strLn center
+ -- copy the pixmap with the new string to the window
+ io $ copyArea d p w gc 0 0 wid ht 0 0
+ -- free up everything (we do not want to leak memory!)
+ io $ freeGC d gc
+ io $ freePixmap d p
+ -- resync
+ io $ sync d True
-- | An easy way to print the stuff we need to print
printStrings :: Drawable -> GC -> XFont -> Position