{-# LANGUAGE CPP #-}
------------------------------------------------------------------------------
-- |
-- Module: ColorCache
-- Copyright: (c) 2012, 2022 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
--
------------------------------------------------------------------------------

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 = (SomeException -> IO DynPixel) -> IO DynPixel -> IO DynPixel
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.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 :: E.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 a. a -> IO a
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
X.blackPixel Display
dpy (ScreenNumber -> Pixel) -> ScreenNumber -> Pixel
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 = IO (IORef ColorCache) -> IORef ColorCache
forall a. IO a -> a
U.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)
IO.newIORef []

getCachedColor :: String -> IO (Maybe X.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 a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IORef ColorCache -> IO ColorCache
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 = IORef ColorCache -> (ColorCache -> ColorCache) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
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' :: 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)
  cached_color <- String -> IO (Maybe Color)
getCachedColor String
c
  c' <- case cached_color of
          Just Color
col -> Color -> IO Color
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Color
col
          Maybe Color
_        -> do (c'', _) <- Display -> Pixel -> String -> IO (Color, Color)
X.allocNamedColor Display
dpy Pixel
colormap String
c
                         putCachedColor c c''
                         return c''
  return $ DynPixel True (X.color_pixel 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
  ps <- (String -> m DynPixel) -> [String] -> m [DynPixel]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO DynPixel -> m DynPixel
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Tr.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
  f $ map (\(DynPixel Bool
_ Pixel
pixel) -> Pixel
pixel) ps