{-# LANGUAGE CPP #-}
#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 ::
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