{-# 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 dpy :: Display
dpy c :: 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 -> Pixel -> Pixel
blackPixel Display
dpy (Pixel -> Pixel) -> Pixel -> Pixel
forall a b. (a -> b) -> a -> b
$ Display -> Pixel
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 color_name :: 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 name :: String
name c_id :: 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
$ \c :: 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' dpy :: Display
dpy c :: String
c = do
let colormap :: Pixel
colormap = Display -> Pixel -> Pixel
defaultColormap Display
dpy (Display -> Pixel
defaultScreen Display
dpy)
Maybe Color
cached_color <- String -> IO (Maybe Color)
getCachedColor String
c
Color
c' <- case Maybe Color
cached_color of
Just col :: Color
col -> Color -> IO Color
forall (m :: * -> *) a. Monad m => a -> m a
return Color
col
_ -> do (c'' :: Color
c'', _) <- 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 d :: Display
d cs :: [String]
cs f :: [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 _ pixel :: Pixel
pixel) -> Pixel
pixel) [DynPixel]
ps
#ifdef XFT
type AXftColorCache = [(String, AXftColor)]
{-# NOINLINE xftColorCache #-}
xftColorCache :: IORef AXftColorCache
xftColorCache :: IORef AXftColorCache
xftColorCache = IO (IORef AXftColorCache) -> IORef AXftColorCache
forall a. IO a -> a
unsafePerformIO (IO (IORef AXftColorCache) -> IORef AXftColorCache)
-> IO (IORef AXftColorCache) -> IORef AXftColorCache
forall a b. (a -> b) -> a -> b
$ AXftColorCache -> IO (IORef AXftColorCache)
forall a. a -> IO (IORef a)
newIORef []
getXftCachedColor :: String -> IO (Maybe AXftColor)
getXftCachedColor :: String -> IO (Maybe AXftColor)
getXftCachedColor name :: String
name = String -> AXftColorCache -> Maybe AXftColor
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name (AXftColorCache -> Maybe AXftColor)
-> IO AXftColorCache -> IO (Maybe AXftColor)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IORef AXftColorCache -> IO AXftColorCache
forall a. IORef a -> IO a
readIORef IORef AXftColorCache
xftColorCache
putXftCachedColor :: String -> AXftColor -> IO ()
putXftCachedColor :: String -> AXftColor -> IO ()
putXftCachedColor name :: String
name cptr :: AXftColor
cptr =
IORef AXftColorCache -> (AXftColorCache -> AXftColorCache) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef AXftColorCache
xftColorCache ((AXftColorCache -> AXftColorCache) -> IO ())
-> (AXftColorCache -> AXftColorCache) -> IO ()
forall a b. (a -> b) -> a -> b
$ \c :: AXftColorCache
c -> (String
name, AXftColor
cptr) (String, AXftColor) -> AXftColorCache -> AXftColorCache
forall a. a -> [a] -> [a]
: AXftColorCache
c
initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor
initAXftColor' :: Display -> Visual -> Pixel -> String -> IO AXftColor
initAXftColor' d :: Display
d v :: Visual
v cm :: Pixel
cm c :: String
c = do
Maybe AXftColor
cc <- String -> IO (Maybe AXftColor)
getXftCachedColor String
c
AXftColor
c' <- case Maybe AXftColor
cc of
Just col :: AXftColor
col -> AXftColor -> IO AXftColor
forall (m :: * -> *) a. Monad m => a -> m a
return AXftColor
col
_ -> do AXftColor
c'' <- Display -> Visual -> Pixel -> String -> IO AXftColor
mallocAXftColor Display
d Visual
v Pixel
cm String
c
String -> AXftColor -> IO ()
putXftCachedColor String
c AXftColor
c''
AXftColor -> IO AXftColor
forall (m :: * -> *) a. Monad m => a -> m a
return AXftColor
c''
AXftColor -> IO AXftColor
forall (m :: * -> *) a. Monad m => a -> m a
return AXftColor
c'
initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor
initAXftColor :: Display -> Visual -> Pixel -> String -> IO AXftColor
initAXftColor d :: Display
d v :: Visual
v cm :: Pixel
cm c :: String
c = (SomeException -> IO AXftColor) -> IO AXftColor -> IO AXftColor
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO AXftColor
black (IO AXftColor -> IO AXftColor) -> IO AXftColor -> IO AXftColor
forall a b. (a -> b) -> a -> b
$ (Display -> Visual -> Pixel -> String -> IO AXftColor
initAXftColor' Display
d Visual
v Pixel
cm String
c)
where
black :: SomeException -> IO AXftColor
black :: SomeException -> IO AXftColor
black = (IO AXftColor -> SomeException -> IO AXftColor
forall a b. a -> b -> a
const (IO AXftColor -> SomeException -> IO AXftColor)
-> IO AXftColor -> SomeException -> IO AXftColor
forall a b. (a -> b) -> a -> b
$ Display -> Visual -> Pixel -> String -> IO AXftColor
initAXftColor' Display
d Visual
v Pixel
cm "black")
withDrawingColors ::
Display -> Drawable -> String -> String
-> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO ()
withDrawingColors :: Display
-> Pixel
-> String
-> String
-> (AXftDraw -> AXftColor -> AXftColor -> IO ())
-> IO ()
withDrawingColors dpy :: Display
dpy drw :: Pixel
drw fc :: String
fc bc :: String
bc f :: AXftDraw -> AXftColor -> AXftColor -> IO ()
f = do
let screen :: Screen
screen = Display -> Screen
defaultScreenOfDisplay Display
dpy
colormap :: Pixel
colormap = Screen -> Pixel
defaultColormapOfScreen Screen
screen
visual :: Visual
visual = Screen -> Visual
defaultVisualOfScreen Screen
screen
AXftColor
fc' <- Display -> Visual -> Pixel -> String -> IO AXftColor
initAXftColor Display
dpy Visual
visual Pixel
colormap String
fc
AXftColor
bc' <- Display -> Visual -> Pixel -> String -> IO AXftColor
initAXftColor Display
dpy Visual
visual Pixel
colormap String
bc
Display -> Pixel -> Visual -> Pixel -> (AXftDraw -> IO ()) -> IO ()
forall a.
Display -> Pixel -> Visual -> Pixel -> (AXftDraw -> IO a) -> IO a
withAXftDraw Display
dpy Pixel
drw Visual
visual Pixel
colormap ((AXftDraw -> IO ()) -> IO ()) -> (AXftDraw -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \draw :: AXftDraw
draw -> AXftDraw -> AXftColor -> AXftColor -> IO ()
f AXftDraw
draw AXftColor
fc' AXftColor
bc'
#endif