summaryrefslogtreecommitdiffhomepage
path: root/XUtil.hsc
diff options
context:
space:
mode:
authornzeh <nzeh@cs.dal.ca>2009-03-24 01:11:23 +0100
committernzeh <nzeh@cs.dal.ca>2009-03-24 01:11:23 +0100
commit530371201a18e497e5ad328c14b93d78bc2017cc (patch)
treead7f3553dd8a03d1756e82502fc3a28afc2e03a2 /XUtil.hsc
parent062b6e457f7e90389a18aef234c3b49373b7eb76 (diff)
downloadxmobar-530371201a18e497e5ad328c14b93d78bc2017cc.tar.gz
xmobar-530371201a18e497e5ad328c14b93d78bc2017cc.tar.bz2
Fix colour allocation leak
darcs-hash:20090324001123-c6b6b-8d31153a5794e56f7abd251bcafa8aa2676193c2.gz
Diffstat (limited to 'XUtil.hsc')
-rw-r--r--XUtil.hsc68
1 files changed, 41 insertions, 27 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.