{-# LINE 1 "src/Xmobar/X11/XRender.hsc" #-}
------------------------------------------------------------------------------
-- |
-- Module: Xmobar.X11.XRender
-- Copyright: (c) 2012, 2014, 2015, 2017, 2022 Jose Antonio Ortega Ruiz
--            (c) Clemens Fruhwirth <clemens@endorphin.org> 2007
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: unportable
-- Created: Sun Sep 11, 2022 01:27
--
--
-- A couple of utilities imported from libxrender to allow alpha blending of
-- an image backgrond.
--
------------------------------------------------------------------------------

{-# 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 XRenderFillRectangle"
-- xRenderFillRectangle :: Display -> PictOp -> Picture -> Ptr XRenderColor -> CInt -> CInt -> CUInt -> CUInt -> IO ()
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

-- Attributes not supported
instance Storable XRenderPictureAttributes where
    sizeOf :: XRenderPictureAttributes -> Int
sizeOf XRenderPictureAttributes
_ = (Int
52)
{-# LINE 56 "src/Xmobar/X11/XRender.hsc" #-}
    alignment _ = alignment (undefined :: CInt)
    peek :: Ptr XRenderPictureAttributes -> IO XRenderPictureAttributes
peek Ptr XRenderPictureAttributes
_ = forall (m :: * -> *) a. Monad m => a -> m a
return XRenderPictureAttributes
XRenderPictureAttributes
    poke :: Ptr XRenderPictureAttributes -> XRenderPictureAttributes -> IO ()
poke Ptr XRenderPictureAttributes
p XRenderPictureAttributes
XRenderPictureAttributes =
        forall a. Ptr a -> PictOp -> CSize -> IO ()
memset Ptr XRenderPictureAttributes
p PictOp
0 (CSize
52)
{-# LINE 60 "src/Xmobar/X11/XRender.hsc" #-}

-- | Convenience function, gives us an XRender handle to a traditional
-- Pixmap.  Don't let it escape.
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
    Ptr XRenderPictFormat
format <- Display -> PictOp -> IO (Ptr XRenderPictFormat)
xRenderFindStandardFormat Display
d PictOp
1 -- PictStandardRGB24
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr XRenderPictureAttributes
attr -> do
        Atom
pic <- Display
-> Atom
-> Ptr XRenderPictFormat
-> CULong
-> Ptr XRenderPictureAttributes
-> IO Atom
xRenderCreatePicture Display
d Atom
p Ptr XRenderPictFormat
format CULong
0 Ptr XRenderPictureAttributes
attr
        Atom -> IO a
f Atom
pic
        Display -> Atom -> IO ()
xRenderFreePicture Display
d Atom
pic

-- | Convenience function, gives us an XRender picture that is a solid
-- fill of color 'c'.  Don't let it escape.
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
    Atom
pic <- forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with XRenderColor
c (Display -> Ptr XRenderColor -> IO Atom
xRenderCreateSolidFill Display
d)
    Atom -> IO a
f Atom
pic
    Display -> Atom -> IO ()
xRenderFreePicture Display
d Atom
pic

-- | Drawing the background to a pixmap and taking into account
-- transparency
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 Atom
wid Atom
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
                        (forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
x) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
y) PictOp
0 PictOp
0
                        PictOp
0 PictOp
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Atom
wid) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Atom
ht)
  forall a. Display -> Atom -> (Atom -> IO a) -> IO ()
withRenderPicture Display
d Atom
p forall a b. (a -> b) -> a -> b
$ \Atom
pic -> do
    -- Handle background color
    XRenderColor
bgcolor <- Display -> String -> IO XRenderColor
parseRenderColor Display
d String
bgc
    forall a. Display -> XRenderColor -> (Atom -> IO a) -> IO ()
withRenderFill Display
d XRenderColor
bgcolor forall a b. (a -> b) -> a -> b
$ \Atom
bgfill ->
      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 forall a. Num a => a -> a -> a
* Int
alpha))
                     (PictOp -> Atom -> Atom -> Atom -> IO ()
render PictOp
pictOpSrc Atom
bgfill Atom
pic)
    -- Handle transparency
    Display -> String -> Bool -> IO Atom
internAtom Display
d String
"_XROOTPMAP_ID" Bool
False forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Atom
xid ->
      let xroot :: Atom
xroot = Display -> Atom
defaultRootWindow Display
d in
      forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Atom
x1 ->
      forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr PictOp
x2 ->
      forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CULong
x3 ->
      forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CULong
x4 ->
      forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca 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
        Ptr CUChar
prop <- forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CUChar)
pprop
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr CUChar
prop forall a. Eq a => a -> a -> Bool
/= forall a. Ptr a
nullPtr) forall a b. (a -> b) -> a -> b
$ do
          Atom
rootbg <- forall a. Storable a => Ptr a -> IO a
peek (forall a b. Ptr a -> Ptr b
castPtr Ptr CUChar
prop) :: IO Pixmap
          forall a. Ptr a -> IO PictOp
xFree Ptr CUChar
prop
          forall a. Display -> Atom -> (Atom -> IO a) -> IO ()
withRenderPicture Display
d Atom
rootbg forall a b. (a -> b) -> a -> b
$ \Atom
bgpic ->
            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 forall a. Num a => a -> a -> a
- Int
257 forall a. Num a => a -> a -> a
* Int
alpha))
                           (PictOp -> Atom -> Atom -> Atom -> IO ()
render PictOp
pictOpAdd Atom
bgpic Atom
pic)

-- | Parses color into XRender color (allocation not necessary!)
parseRenderColor :: Display -> String -> IO XRenderColor
parseRenderColor :: Display -> String -> IO XRenderColor
parseRenderColor Display
d String
c = do
    let colormap :: Atom
colormap = Display -> Atom -> Atom
defaultColormap Display
d (Display -> Atom
defaultScreen Display
d)
    Color Atom
_ Word16
red Word16
green Word16
blue Word8
_ <- Display -> Atom -> String -> IO Color
parseColor Display
d Atom
colormap String
c
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> XRenderColor
XRenderColor (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
red)
                          (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
green)
                          (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
blue)
                          Int
0xFFFF

pictOpSrc, pictOpAdd :: PictOp
pictOpSrc :: PictOp
pictOpSrc = PictOp
1
pictOpAdd :: PictOp
pictOpAdd = PictOp
12

-- pictOpMinimum = 0
-- pictOpClear = 0
-- pictOpDst = 2
-- pictOpOver = 3
-- pictOpOverReverse = 4
-- pictOpIn = 5
-- pictOpInReverse = 6
-- pictOpOut = 7
-- pictOpOutReverse = 8
-- pictOpAtop = 9
-- pictOpAtopReverse = 10
-- pictOpXor = 11
-- pictOpSaturate = 13
-- pictOpMaximum = 13