{-# LANGUAGE CPP #-}
module Xmobar.X11.ColorCache(withColors) where
import qualified Data.IORef as IO
import qualified System.IO.Unsafe as U
import qualified Control.Exception as E
import qualified Control.Monad.Trans as Tr
import qualified Graphics.X11.Xlib as X
data DynPixel = DynPixel Bool X.Pixel
initColor :: X.Display -> String -> IO DynPixel
initColor :: Display -> String -> IO DynPixel
initColor Display
dpy String
c = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle SomeException -> IO DynPixel
black forall a b. (a -> b) -> a -> b
$ Display -> String -> IO DynPixel
initColor' Display
dpy String
c
where
black :: E.SomeException -> IO DynPixel
black :: SomeException -> IO DynPixel
black = forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Pixel -> DynPixel
DynPixel Bool
False (Display -> ScreenNumber -> Pixel
X.blackPixel Display
dpy forall a b. (a -> b) -> a -> b
$ Display -> ScreenNumber
X.defaultScreen Display
dpy)
type ColorCache = [(String, X.Color)]
{-# NOINLINE colorCache #-}
colorCache :: IO.IORef ColorCache
colorCache :: IORef ColorCache
colorCache = forall a. IO a -> a
U.unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
IO.newIORef []
getCachedColor :: String -> IO (Maybe X.Color)
getCachedColor :: String -> IO (Maybe Color)
getCachedColor String
color_name = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
color_name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. IORef a -> IO a
IO.readIORef IORef ColorCache
colorCache
putCachedColor :: String -> X.Color -> IO ()
putCachedColor :: String -> Color -> IO ()
putCachedColor String
name Color
c_id = forall a. IORef a -> (a -> a) -> IO ()
IO.modifyIORef IORef ColorCache
colorCache forall a b. (a -> b) -> a -> b
$ \ColorCache
c -> (String
name, Color
c_id) forall a. a -> [a] -> [a]
: ColorCache
c
initColor' :: X.Display -> String -> IO DynPixel
initColor' :: Display -> String -> IO DynPixel
initColor' Display
dpy String
c = do
let colormap :: Pixel
colormap = Display -> ScreenNumber -> Pixel
X.defaultColormap Display
dpy (Display -> ScreenNumber
X.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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Color
col
Maybe Color
_ -> do (Color
c'', Color
_) <- Display -> Pixel -> String -> IO (Color, Color)
X.allocNamedColor Display
dpy Pixel
colormap String
c
String -> Color -> IO ()
putCachedColor String
c Color
c''
forall (m :: * -> *) a. Monad m => a -> m a
return Color
c''
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Pixel -> DynPixel
DynPixel Bool
True (Color -> Pixel
X.color_pixel Color
c')
withColors :: Tr.MonadIO m => X.Display -> [String] -> ([X.Pixel] -> m a) -> m a
withColors :: forall (m :: * -> *) a.
MonadIO m =>
Display -> [String] -> ([Pixel] -> m a) -> m a
withColors Display
d [String]
cs [Pixel] -> m a
f = do
[DynPixel]
ps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
Tr.liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> String -> IO DynPixel
initColor Display
d) [String]
cs
[Pixel] -> m a
f forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(DynPixel Bool
_ Pixel
pixel) -> Pixel
pixel) [DynPixel]
ps