Fix colour allocation leak

darcs-hash:20090324001123-c6b6b-8d31153a5794e56f7abd251bcafa8aa2676193c2.gz

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