{-# LANGUAGE CPP #-}
------------------------------------------------------------------------------
-- |
-- Module: ColorCache
-- Copyright: (c) 2012 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: unportable
-- Created: Mon Sep 10, 2012 00:27
--
--
-- Caching X colors
--
------------------------------------------------------------------------------

#if defined XFT

module Xmobar.X11.ColorCache(withColors, withDrawingColors) where

import Xmobar.X11.MinXft

#else

module Xmobar.X11.ColorCache(withColors) where

#endif

import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Exception (SomeException, handle)
import Graphics.X11.Xlib

data DynPixel = DynPixel Bool Pixel

initColor :: Display -> String -> IO DynPixel
initColor :: Display -> String -> IO DynPixel
initColor Display
dpy String
c = (SomeException -> IO DynPixel) -> IO DynPixel -> IO DynPixel
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO DynPixel
black (IO DynPixel -> IO DynPixel) -> IO DynPixel -> IO DynPixel
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO DynPixel
initColor' Display
dpy String
c
  where
    black :: SomeException -> IO DynPixel
    black :: SomeException -> IO DynPixel
black = IO DynPixel -> SomeException -> IO DynPixel
forall a b. a -> b -> a
const (IO DynPixel -> SomeException -> IO DynPixel)
-> (DynPixel -> IO DynPixel)
-> DynPixel
-> SomeException
-> IO DynPixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynPixel -> IO DynPixel
forall (m :: * -> *) a. Monad m => a -> m a
return (DynPixel -> SomeException -> IO DynPixel)
-> DynPixel -> SomeException -> IO DynPixel
forall a b. (a -> b) -> a -> b
$ Bool -> Pixel -> DynPixel
DynPixel Bool
False (Display -> ScreenNumber -> Pixel
blackPixel Display
dpy (ScreenNumber -> Pixel) -> ScreenNumber -> Pixel
forall a b. (a -> b) -> a -> b
$ Display -> ScreenNumber
defaultScreen Display
dpy)

type ColorCache = [(String, Color)]
{-# NOINLINE colorCache #-}
colorCache :: IORef ColorCache
colorCache :: IORef ColorCache
colorCache = IO (IORef ColorCache) -> IORef ColorCache
forall a. IO a -> a
unsafePerformIO (IO (IORef ColorCache) -> IORef ColorCache)
-> IO (IORef ColorCache) -> IORef ColorCache
forall a b. (a -> b) -> a -> b
$ ColorCache -> IO (IORef ColorCache)
forall a. a -> IO (IORef a)
newIORef []

getCachedColor :: String -> IO (Maybe Color)
getCachedColor :: String -> IO (Maybe Color)
getCachedColor String
color_name = String -> ColorCache -> Maybe Color
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
color_name (ColorCache -> Maybe Color) -> IO ColorCache -> IO (Maybe Color)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IORef ColorCache -> IO ColorCache
forall a. IORef a -> IO a
readIORef IORef ColorCache
colorCache

putCachedColor :: String -> Color -> IO ()
putCachedColor :: String -> Color -> IO ()
putCachedColor String
name Color
c_id = IORef ColorCache -> (ColorCache -> ColorCache) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ColorCache
colorCache ((ColorCache -> ColorCache) -> IO ())
-> (ColorCache -> ColorCache) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ColorCache
c -> (String
name, Color
c_id) (String, Color) -> ColorCache -> ColorCache
forall a. a -> [a] -> [a]
: ColorCache
c

initColor' :: Display -> String -> IO DynPixel
initColor' :: Display -> String -> IO DynPixel
initColor' Display
dpy String
c = do
  let colormap :: Pixel
colormap = Display -> ScreenNumber -> Pixel
defaultColormap Display
dpy (Display -> ScreenNumber
defaultScreen Display
dpy)
  Maybe Color
cached_color <- String -> IO (Maybe Color)
getCachedColor String
c
  Color
c' <- case Maybe Color
cached_color of
          Just Color
col -> Color -> IO Color
forall (m :: * -> *) a. Monad m => a -> m a
return Color
col
          Maybe Color
_        -> do (Color
c'', Color
_) <- Display -> Pixel -> String -> IO (Color, Color)
allocNamedColor Display
dpy Pixel
colormap String
c
                         String -> Color -> IO ()
putCachedColor String
c Color
c''
                         Color -> IO Color
forall (m :: * -> *) a. Monad m => a -> m a
return Color
c''
  DynPixel -> IO DynPixel
forall (m :: * -> *) a. Monad m => a -> m a
return (DynPixel -> IO DynPixel) -> DynPixel -> IO DynPixel
forall a b. (a -> b) -> a -> b
$ Bool -> Pixel -> DynPixel
DynPixel Bool
True (Color -> Pixel
color_pixel Color
c')

withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a
withColors :: Display -> [String] -> ([Pixel] -> m a) -> m a
withColors Display
d [String]
cs [Pixel] -> m a
f = do
  [DynPixel]
ps <- (String -> m DynPixel) -> [String] -> m [DynPixel]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO DynPixel -> m DynPixel
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynPixel -> m DynPixel)
-> (String -> IO DynPixel) -> String -> m DynPixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> String -> IO DynPixel
initColor Display
d) [String]
cs
  [Pixel] -> m a
f ([Pixel] -> m a) -> [Pixel] -> m a
forall a b. (a -> b) -> a -> b
$ (DynPixel -> Pixel) -> [DynPixel] -> [Pixel]
forall a b. (a -> b) -> [a] -> [b]
map (\(DynPixel Bool
_ Pixel
pixel) -> Pixel
pixel) [DynPixel]
ps

#ifdef XFT

type AXftColorCache = [(String, AXftColor)]
{-# NOINLINE xftColorCache #-}
xftColorCache :: IORef AXftColorCache
xftColorCache = unsafePerformIO $ newIORef []

getXftCachedColor :: String -> IO (Maybe AXftColor)
getXftCachedColor name = lookup name `fmap` readIORef xftColorCache

putXftCachedColor :: String -> AXftColor -> IO ()
putXftCachedColor name cptr =
  modifyIORef xftColorCache $ \c -> (name, cptr) : c

initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor
initAXftColor' d v cm c = do
  cc <- getXftCachedColor c
  c' <- case cc of
          Just col -> return col
          _        -> do c'' <- mallocAXftColor d v cm c
                         putXftCachedColor c c''
                         return c''
  return c'

initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor
initAXftColor d v cm c = handle black $ (initAXftColor' d v cm c)
  where
    black :: SomeException -> IO AXftColor
    black = (const $ initAXftColor' d v cm "black")

withDrawingColors :: -- MonadIO m =>
                     Display -> Drawable -> String -> String
                    -> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO ()
withDrawingColors dpy drw fc bc f = do
  let screen = defaultScreenOfDisplay dpy
      colormap = defaultColormapOfScreen screen
      visual = defaultVisualOfScreen screen
  fc' <- initAXftColor dpy visual colormap fc
  bc' <- initAXftColor dpy visual colormap bc
  withAXftDraw dpy drw visual colormap $ \draw -> f draw fc' bc'
#endif