1{-# LANGUAGE CPP #-} 2------------------------------------------------------------------------------ 3-- | 4-- Module: ColorCache 5-- Copyright: (c) 2012 Jose Antonio Ortega Ruiz 6-- License: BSD3-style (see LICENSE) 7-- 8-- Maintainer: jao@gnu.org 9-- Stability: unstable 10-- Portability: unportable 11-- Created: Mon Sep 10, 2012 00:27 12-- 13-- 14-- Caching X colors 15-- 16------------------------------------------------------------------------------ 17 18#if defined XFT 19 20module Xmobar.X11.ColorCache(withColors, withDrawingColors) where 21 22import Xmobar.X11.MinXft 23 24#else 25 26module Xmobar.X11.ColorCache(withColors) where 27 28#endif 29 30import Data.IORef 31import System.IO.Unsafe (unsafePerformIO) 32import Control.Monad.Trans (MonadIO, liftIO) 33import Control.Exception (SomeException, handle) 34import Graphics.X11.Xlib 35 36data DynPixel = DynPixel Bool Pixel 37 38initColor :: Display -> String -> IO DynPixel 39initColor dpy c = handle black $ initColor' dpy c 40 where 41 black :: SomeException -> IO DynPixel 42 black = const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy) 43 44type ColorCache = [(String, Color)] 45{-# NOINLINE colorCache #-} 46colorCache :: IORef ColorCache 47colorCache = unsafePerformIO $ newIORef [] 48 49getCachedColor :: String -> IO (Maybe Color) 50getCachedColor color_name = lookup color_name `fmap` readIORef colorCache 51 52putCachedColor :: String -> Color -> IO () 53putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c 54 55initColor' :: Display -> String -> IO DynPixel 56initColor' dpy c = do 57 let colormap = defaultColormap dpy (defaultScreen dpy) 58 cached_color <- getCachedColor c 59 c' <- case cached_color of 60 Just col -> return col 61 _ -> do (c'', _) <- allocNamedColor dpy colormap c 62 putCachedColor c c'' 63 return c'' 64 return $ DynPixel True (color_pixel c') 65 66withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a 67withColors d cs f = do 68 ps <- mapM (liftIO . initColor d) cs 69 f $ map (\(DynPixel _ pixel) -> pixel) ps 70 71#ifdef XFT 72 73type AXftColorCache = [(String, AXftColor)] 74{-# NOINLINE xftColorCache #-} 75xftColorCache :: IORef AXftColorCache 76xftColorCache = unsafePerformIO $ newIORef [] 77 78getXftCachedColor :: String -> IO (Maybe AXftColor) 79getXftCachedColor name = lookup name `fmap` readIORef xftColorCache 80 81putXftCachedColor :: String -> AXftColor -> IO () 82putXftCachedColor name cptr = 83 modifyIORef xftColorCache $ \c -> (name, cptr) : c 84 85initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor 86initAXftColor' d v cm c = do 87 cc <- getXftCachedColor c 88 c' <- case cc of 89 Just col -> return col 90 _ -> do c'' <- mallocAXftColor d v cm c 91 putXftCachedColor c c'' 92 return c'' 93 return c' 94 95initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor 96initAXftColor d v cm c = handle black $ (initAXftColor' d v cm c) 97 where 98 black :: SomeException -> IO AXftColor 99 black = (const $ initAXftColor' d v cm "black") 100 101withDrawingColors :: -- MonadIO m => 102 Display -> Drawable -> String -> String 103 -> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO () 104withDrawingColors dpy drw fc bc f = do 105 let screen = defaultScreenOfDisplay dpy 106 colormap = defaultColormapOfScreen screen 107 visual = defaultVisualOfScreen screen 108 fc' <- initAXftColor dpy visual colormap fc 109 bc' <- initAXftColor dpy visual colormap bc 110 withAXftDraw dpy drw visual colormap $ \draw -> f draw fc' bc' 111#endif 112