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