diff options
| -rw-r--r-- | XUtil.hsc | 68 | ||||
| -rw-r--r-- | Xmobar.hs | 38 |
2 files changed, 60 insertions, 46 deletions
@@ -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. @@ -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 |