{-# LINE 1 "src/Xmobar/X11/XRender.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
module Xmobar.X11.XRender (drawBackground) where
import Graphics.X11
import Graphics.X11.Xrender
import Graphics.X11.Xlib.Extras (xGetWindowProperty, xFree)
import Control.Monad (when)
import Foreign
import Foreign.C.Types
type Picture = XID
type PictOp = CInt
data XRenderPictFormat
data XRenderPictureAttributes = XRenderPictureAttributes
foreign import ccall unsafe "X11/extensions/Xrender.h XRenderComposite"
xRenderComposite :: Display -> PictOp -> Picture -> Picture -> Picture -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CUInt -> CUInt -> IO ()
foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreateSolidFill"
xRenderCreateSolidFill :: Display -> Ptr XRenderColor -> IO Picture
foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFreePicture"
xRenderFreePicture :: Display -> Picture -> IO ()
foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO ()
foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFindStandardFormat"
xRenderFindStandardFormat :: Display -> CInt -> IO (Ptr XRenderPictFormat)
foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreatePicture"
xRenderCreatePicture :: Display -> Drawable -> Ptr XRenderPictFormat -> CULong -> Ptr XRenderPictureAttributes -> IO Picture
instance Storable XRenderPictureAttributes where
sizeOf :: XRenderPictureAttributes -> Int
sizeOf XRenderPictureAttributes
_ = (Int
72)
{-# LINE 56 "src/Xmobar/X11/XRender.hsc" #-}
alignment _ = alignment (undefined :: CInt)
peek :: Ptr XRenderPictureAttributes -> IO XRenderPictureAttributes
peek Ptr XRenderPictureAttributes
_ = XRenderPictureAttributes -> IO XRenderPictureAttributes
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return XRenderPictureAttributes
XRenderPictureAttributes
poke :: Ptr XRenderPictureAttributes -> XRenderPictureAttributes -> IO ()
poke Ptr XRenderPictureAttributes
p XRenderPictureAttributes
XRenderPictureAttributes =
Ptr XRenderPictureAttributes -> PictOp -> CSize -> IO ()
forall a. Ptr a -> PictOp -> CSize -> IO ()
memset Ptr XRenderPictureAttributes
p PictOp
0 (CSize
72)
{-# LINE 60 "src/Xmobar/X11/XRender.hsc" #-}
withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO ()
withRenderPicture :: forall a. Display -> Atom -> (Atom -> IO a) -> IO ()
withRenderPicture Display
d Atom
p Atom -> IO a
f = do
format <- Display -> PictOp -> IO (Ptr XRenderPictFormat)
xRenderFindStandardFormat Display
d PictOp
1
alloca $ \Ptr XRenderPictureAttributes
attr -> do
pic <- Display
-> Atom
-> Ptr XRenderPictFormat
-> CULong
-> Ptr XRenderPictureAttributes
-> IO Atom
xRenderCreatePicture Display
d Atom
p Ptr XRenderPictFormat
format CULong
0 Ptr XRenderPictureAttributes
attr
f pic
xRenderFreePicture d pic
withRenderFill :: Display -> XRenderColor -> (Picture -> IO a) -> IO ()
withRenderFill :: forall a. Display -> XRenderColor -> (Atom -> IO a) -> IO ()
withRenderFill Display
d XRenderColor
c Atom -> IO a
f = do
pic <- XRenderColor -> (Ptr XRenderColor -> IO Atom) -> IO Atom
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with XRenderColor
c (Display -> Ptr XRenderColor -> IO Atom
xRenderCreateSolidFill Display
d)
f pic
xRenderFreePicture d pic
drawBackground :: Display -> Drawable -> String -> Int -> Rectangle -> IO ()
drawBackground :: Display -> Atom -> String -> Int -> Rectangle -> IO ()
drawBackground Display
d Atom
p String
bgc Int
alpha (Rectangle Position
x Position
y Dimension
wid Dimension
ht) = do
let render :: PictOp -> Atom -> Atom -> Atom -> IO ()
render PictOp
opt Atom
bg Atom
pic Atom
m =
Display
-> PictOp
-> Atom
-> Atom
-> Atom
-> PictOp
-> PictOp
-> PictOp
-> PictOp
-> PictOp
-> PictOp
-> CUInt
-> CUInt
-> IO ()
xRenderComposite Display
d PictOp
opt Atom
bg Atom
m Atom
pic
(Position -> PictOp
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
x) (Position -> PictOp
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
y) PictOp
0 PictOp
0
PictOp
0 PictOp
0 (Dimension -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
wid) (Dimension -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
ht)
Display -> Atom -> (Atom -> IO ()) -> IO ()
forall a. Display -> Atom -> (Atom -> IO a) -> IO ()
withRenderPicture Display
d Atom
p ((Atom -> IO ()) -> IO ()) -> (Atom -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Atom
pic -> do
bgcolor <- Display -> String -> IO XRenderColor
parseRenderColor Display
d String
bgc
withRenderFill d bgcolor $ \Atom
bgfill ->
Display -> XRenderColor -> (Atom -> IO ()) -> IO ()
forall a. Display -> XRenderColor -> (Atom -> IO a) -> IO ()
withRenderFill Display
d
(Int -> Int -> Int -> Int -> XRenderColor
XRenderColor Int
0 Int
0 Int
0 (Int
257 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
alpha))
(PictOp -> Atom -> Atom -> Atom -> IO ()
render PictOp
pictOpSrc Atom
bgfill Atom
pic)
internAtom d "_XROOTPMAP_ID" False >>= \Atom
xid ->
let xroot :: Atom
xroot = Display -> Atom
defaultRootWindow Display
d in
(Ptr Atom -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Atom -> IO ()) -> IO ()) -> (Ptr Atom -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Atom
x1 ->
(Ptr PictOp -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr PictOp -> IO ()) -> IO ()) -> (Ptr PictOp -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr PictOp
x2 ->
(Ptr CULong -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULong -> IO ()) -> IO ()) -> (Ptr CULong -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CULong
x3 ->
(Ptr CULong -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULong -> IO ()) -> IO ()) -> (Ptr CULong -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CULong
x4 ->
(Ptr (Ptr CUChar) -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr CUChar) -> IO ()) -> IO ())
-> (Ptr (Ptr CUChar) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CUChar)
pprop -> do
Display
-> Atom
-> Atom
-> CLong
-> CLong
-> Bool
-> Atom
-> Ptr Atom
-> Ptr PictOp
-> Ptr CULong
-> Ptr CULong
-> Ptr (Ptr CUChar)
-> IO PictOp
xGetWindowProperty Display
d Atom
xroot Atom
xid CLong
0 CLong
1 Bool
False Atom
20 Ptr Atom
x1 Ptr PictOp
x2 Ptr CULong
x3 Ptr CULong
x4 Ptr (Ptr CUChar)
pprop
prop <- Ptr (Ptr CUChar) -> IO (Ptr CUChar)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CUChar)
pprop
when (prop /= nullPtr) $ do
rootbg <- peek (castPtr prop) :: IO Pixmap
xFree prop
withRenderPicture d rootbg $ \Atom
bgpic ->
Display -> XRenderColor -> (Atom -> IO ()) -> IO ()
forall a. Display -> XRenderColor -> (Atom -> IO a) -> IO ()
withRenderFill Display
d (Int -> Int -> Int -> Int -> XRenderColor
XRenderColor Int
0 Int
0 Int
0 (Int
0xFFFF Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
257 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
alpha))
(PictOp -> Atom -> Atom -> Atom -> IO ()
render PictOp
pictOpAdd Atom
bgpic Atom
pic)
parseRenderColor :: Display -> String -> IO XRenderColor
parseRenderColor :: Display -> String -> IO XRenderColor
parseRenderColor Display
d String
c = do
let colormap :: Atom
colormap = Display -> Dimension -> Atom
defaultColormap Display
d (Display -> Dimension
defaultScreen Display
d)
Color _ red green blue _ <- Display -> Atom -> String -> IO Color
parseColor Display
d Atom
colormap String
c
return $ XRenderColor (fromIntegral red)
(fromIntegral green)
(fromIntegral blue)
0xFFFF
pictOpSrc, pictOpAdd :: PictOp
pictOpSrc :: PictOp
pictOpSrc = PictOp
1
pictOpAdd :: PictOp
pictOpAdd = PictOp
12