diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ColorCache.hs | 66 | ||||
| -rw-r--r-- | src/XUtil.hsc | 88 | ||||
| -rw-r--r-- | src/Xmobar.hs | 6 |
3 files changed, 96 insertions, 64 deletions
diff --git a/src/ColorCache.hs b/src/ColorCache.hs new file mode 100644 index 0000000..9a76a90 --- /dev/null +++ b/src/ColorCache.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE CPP #-} +------------------------------------------------------------------------------ +-- | +-- Module: ColorCache +-- Copyright: (c) 2012 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Mon Sep 10, 2012 00:27 +-- +-- +-- Caching X colors +-- +------------------------------------------------------------------------------ + +module ColorCache(withColors) where + +#if defined XFT +-- import Graphics.X11.Xft +#endif +import Data.IORef +import Graphics.X11.Xlib +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Exception (SomeException, handle) + +data DynPixel = DynPixel { allocated :: Bool + , pixel :: Pixel + } + +-- | Get the Pixel value for a named color: if an invalid name is +-- given the black pixel will be returned. +initColor :: Display -> String -> IO DynPixel +initColor dpy c = handle black $ (initColor' dpy c) + where + black :: SomeException -> IO DynPixel + black = (const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy)) + +type ColorCache = [(String, Color)] +{-# NOINLINE colorCache #-} +colorCache :: IORef ColorCache +colorCache = unsafePerformIO $ newIORef [] + +getCachedColor :: String -> IO (Maybe Color) +getCachedColor color_name = lookup color_name `fmap` readIORef colorCache + +putCachedColor :: String -> Color -> IO () +putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c + +initColor' :: Display -> String -> IO DynPixel +initColor' dpy c = do + let colormap = defaultColormap dpy (defaultScreen dpy) + cached_color <- getCachedColor c + c' <- case cached_color of + Just col -> return col + _ -> do (c'', _) <- allocNamedColor dpy colormap c + putCachedColor c c'' + return c'' + return $ DynPixel True (color_pixel c') + +withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a +withColors d cs f = do + ps <- mapM (liftIO . initColor d) cs + f $ map pixel ps diff --git a/src/XUtil.hsc b/src/XUtil.hsc index b736c9c..7683387 100644 --- a/src/XUtil.hsc +++ b/src/XUtil.hsc @@ -20,20 +20,17 @@ module XUtil , textExtents , textWidth , printString - , initColor , newWindow , nextEvent' , readFileSafe , hGetLineSafe , io , fi - , withColors - , DynPixel(..) ) where import Control.Concurrent import Control.Monad.Trans -import Data.IORef +import Control.Exception (SomeException, handle) import Foreign -- import Foreign.C.Types import Graphics.X11.Xlib hiding (textExtents, textWidth) @@ -55,6 +52,8 @@ import Graphics.X11.Xft import Graphics.X11.Xrender #endif +import ColorCache (withColors) + readFileSafe :: FilePath -> IO String #if defined XFT || defined UTF8 readFileSafe = UTF8.readFile @@ -76,8 +75,8 @@ data XFont = Core FontStruct | Xft XftFont #endif --- | When initFont gets a font name that starts with 'xft:' it switchs to the Xft backend --- Example: 'xft:Sans-10' +-- | When initFont gets a font name that starts with 'xft:' it switchs +-- to the Xft backend Example: 'xft:Sans-10' initFont :: Display ->String -> IO XFont initFont d s = #ifdef XFT @@ -92,26 +91,31 @@ initFont d s = fmap Core $ initCoreFont d s #endif +miscFixedFont :: String +miscFixedFont = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + -- | Given a fontname returns the font structure. If the font name is -- not valid the default font will be loaded and returned. initCoreFont :: Display -> String -> IO FontStruct initCoreFont d s = do - f <- catch getIt fallBack + f <- handle fallBack getIt addFinalizer f (freeFont d f) return f - where getIt = loadQueryFont d s - fallBack = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + where getIt = loadQueryFont d s + fallBack :: SomeException -> IO FontStruct + fallBack = const $ loadQueryFont d miscFixedFont -- | Given a fontname returns the font structure. If the font name is -- not valid the default font will be loaded and returned. initUtf8Font :: Display -> String -> IO FontSet initUtf8Font d s = do setupLocale - (_,_,f) <- catch getIt fallBack + (_,_,f) <- handle fallBack getIt addFinalizer f (freeFontSet d f) return f - where getIt = createFontSet d s - fallBack = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + where getIt = createFontSet d s + fallBack :: SomeException -> IO ([String], String, FontSet) + fallBack = const $ createFontSet d miscFixedFont #ifdef XFT initXftFont :: Display -> String -> IO XftFont @@ -163,59 +167,23 @@ printString d p (Utf8 fs) gc fc bc x y s = io $ wcDrawImageString d p fs gc x y s #ifdef XFT -printString dpy drw fs@(Xft font) gc fc bc x y s = do +printString dpy drw fs@(Xft font) _ fc bc x y s = do let screen = defaultScreenOfDisplay dpy colormap = defaultColormapOfScreen screen visual = defaultVisualOfScreen screen - withColors dpy [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 + d)) - (fi $ xglyphinfo_xOff gi) - (fi $ 4 + a + d) - withXftDraw dpy drw visual colormap $ - \draw -> withXftColorName dpy visual colormap fc $ - \color -> xftDrawString draw color font x (y - 2) s + (a,d) <- textExtents fs s + gi <- xftTextExtents dpy font s + withXftDraw dpy drw visual colormap $ \draw -> + (withXftColorName dpy visual colormap bc $ \color -> + xftDrawRect draw color (x + 1 - fi (xglyphinfo_x gi)) + (y - (a + d) + 1) + (xglyphinfo_xOff gi) + (a + d) + ) >> + (withXftColorName dpy visual colormap fc $ \color -> + xftDrawString draw color font x (y - 2) s) #endif -data DynPixel = DynPixel { allocated :: Bool - , pixel :: Pixel - } - --- | Get the Pixel value for a named color: if an invalid name is --- given the black pixel will be returned. -initColor :: Display -> String -> IO DynPixel -initColor dpy c = (initColor' dpy c) `catch` - (const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy)) - -type ColorCache = [(String, Color)] -{-# NOINLINE colorCache #-} -colorCache :: IORef ColorCache -colorCache = unsafePerformIO $ newIORef [] - -getCachedColor :: String -> IO (Maybe Color) -getCachedColor color_name = lookup color_name `fmap` readIORef colorCache - -putCachedColor :: String -> Color -> IO () -putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c - -initColor' :: Display -> String -> IO DynPixel -initColor' dpy c = do - let colormap = defaultColormap dpy (defaultScreen dpy) - cached_color <- getCachedColor c - c' <- case cached_color of - Just col -> return col - _ -> do (c'', _) <- allocNamedColor dpy colormap c - putCachedColor c c'' - return c'' - return $ DynPixel True (color_pixel c') - -withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a -withColors d cs f = do - ps <- mapM (io . initColor d) cs - f $ map pixel ps -- | Creates a window with the attribute override_redirect set to True. -- Windows Managers should not touch this kind of windows. diff --git a/src/Xmobar.hs b/src/Xmobar.hs index de0de0a..3d17fad 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -49,6 +49,7 @@ import Runnable import Signal import Window import XUtil +import ColorCache #ifdef DBUS import IPC.DBus @@ -262,7 +263,7 @@ printStrings dr gc fontst offs a sl@((s,c,l):xs) = do let (conf,d) = (config &&& display) r Rectangle _ _ wid ht = rect r totSLen = foldr (\(_,_,len) -> (+) len) 0 sl - valign = ((fi ht + fi (as + ds)) `div` 2) - 1 + valign = -1 + (fi ht + fi (as + ds)) `div` 2 remWidth = fi wid - fi totSLen offset = case a of C -> (remWidth + offs) `div` 2 @@ -271,8 +272,5 @@ 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) - withColors d [bc] $ \[bc'] -> do - io $ setForeground d gc bc' - io $ fillRectangle d dr gc offset 0 (fi l) ht io $ printString d dr fontst gc fc bc offset valign s printStrings dr gc fontst (offs + l) a xs |