{-# 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
72)
{-# LINE 56 "src/Xmobar/X11/XRender.hsc" #-}
    alignment _ = alignment (undefined :: CInt)
    peek :: Ptr XRenderPictureAttributes -> IO XRenderPictureAttributes
peek Ptr XRenderPictureAttributes
_ = XRenderPictureAttributes -> IO XRenderPictureAttributes
forall (m :: * -> *) a. Monad m => a -> m a
return XRenderPictureAttributes
XRenderPictureAttributes
    poke :: Ptr XRenderPictureAttributes -> XRenderPictureAttributes -> IO ()
poke Ptr XRenderPictureAttributes
p XRenderPictureAttributes
XRenderPictureAttributes =
        Ptr XRenderPictureAttributes -> CInt -> CSize -> IO ()
forall a. Ptr a -> CInt -> CSize -> IO ()
memset Ptr XRenderPictureAttributes
p CInt
0 (CSize
72)
{-# 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 :: Display -> Drawable -> (Drawable -> IO a) -> IO ()
withRenderPicture Display
d Drawable
p Drawable -> IO a
f = do
    Ptr XRenderPictFormat
format <- Display -> CInt -> IO (Ptr XRenderPictFormat)
xRenderFindStandardFormat Display
d CInt
1 -- PictStandardRGB24
    (Ptr XRenderPictureAttributes -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr XRenderPictureAttributes -> IO ()) -> IO ())
-> (Ptr XRenderPictureAttributes -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr XRenderPictureAttributes
attr -> do
        Drawable
pic <- Display
-> Drawable
-> Ptr XRenderPictFormat
-> CULong
-> Ptr XRenderPictureAttributes
-> IO Drawable
xRenderCreatePicture Display
d Drawable
p Ptr XRenderPictFormat
format CULong
0 Ptr XRenderPictureAttributes
attr
        Drawable -> IO a
f Drawable
pic
        Display -> Drawable -> IO ()
xRenderFreePicture Display
d Drawable
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 :: Display -> XRenderColor -> (Drawable -> IO a) -> IO ()
withRenderFill Display
d XRenderColor
c Drawable -> IO a
f = do
    Drawable
pic <- XRenderColor -> (Ptr XRenderColor -> IO Drawable) -> IO Drawable
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with XRenderColor
c (Display -> Ptr XRenderColor -> IO Drawable
xRenderCreateSolidFill Display
d)
    Drawable -> IO a
f Drawable
pic
    Display -> Drawable -> IO ()
xRenderFreePicture Display
d Drawable
pic

-- | Drawing the background to a pixmap and taking into account
-- transparency
drawBackground ::  Display -> Drawable -> String -> Int -> Rectangle -> IO ()
drawBackground :: Display -> Drawable -> String -> Int -> Rectangle -> IO ()
drawBackground Display
d Drawable
p String
bgc Int
alpha (Rectangle Position
x Position
y Dimension
wid Dimension
ht) = do
  let render :: CInt -> Drawable -> Drawable -> Drawable -> IO ()
render CInt
opt Drawable
bg Drawable
pic Drawable
m =
        Display
-> CInt
-> Drawable
-> Drawable
-> Drawable
-> CInt
-> CInt
-> CInt
-> CInt
-> CInt
-> CInt
-> CUInt
-> CUInt
-> IO ()
xRenderComposite Display
d CInt
opt Drawable
bg Drawable
m Drawable
pic
                        (Position -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
x) (Position -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
y) CInt
0 CInt
0
                        CInt
0 CInt
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 -> Drawable -> (Drawable -> IO ()) -> IO ()
forall a. Display -> Drawable -> (Drawable -> IO a) -> IO ()
withRenderPicture Display
d Drawable
p ((Drawable -> IO ()) -> IO ()) -> (Drawable -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Drawable
pic -> do
    -- Handle background color
    XRenderColor
bgcolor <- Display -> String -> IO XRenderColor
parseRenderColor Display
d String
bgc
    Display -> XRenderColor -> (Drawable -> IO ()) -> IO ()
forall a. Display -> XRenderColor -> (Drawable -> IO a) -> IO ()
withRenderFill Display
d XRenderColor
bgcolor ((Drawable -> IO ()) -> IO ()) -> (Drawable -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Drawable
bgfill ->
      Display -> XRenderColor -> (Drawable -> IO ()) -> IO ()
forall a. Display -> XRenderColor -> (Drawable -> 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))
                     (CInt -> Drawable -> Drawable -> Drawable -> IO ()
render CInt
pictOpSrc Drawable
bgfill Drawable
pic)
    -- Handle transparency
    Display -> String -> Bool -> IO Drawable
internAtom Display
d String
"_XROOTPMAP_ID" Bool
False IO Drawable -> (Drawable -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Drawable
xid ->
      let xroot :: Drawable
xroot = Display -> Drawable
defaultRootWindow Display
d in
      (Ptr Drawable -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Drawable -> IO ()) -> IO ())
-> (Ptr Drawable -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Drawable
x1 ->
      (Ptr CInt -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO ()) -> IO ()) -> (Ptr CInt -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
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
-> Drawable
-> Drawable
-> CLong
-> CLong
-> Bool
-> Drawable
-> Ptr Drawable
-> Ptr CInt
-> Ptr CULong
-> Ptr CULong
-> Ptr (Ptr CUChar)
-> IO CInt
xGetWindowProperty Display
d Drawable
xroot Drawable
xid CLong
0 CLong
1 Bool
False Drawable
20 Ptr Drawable
x1 Ptr CInt
x2 Ptr CULong
x3 Ptr CULong
x4 Ptr (Ptr CUChar)
pprop
        Ptr CUChar
prop <- Ptr (Ptr CUChar) -> IO (Ptr CUChar)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CUChar)
pprop
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr CUChar
prop Ptr CUChar -> Ptr CUChar -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr CUChar
forall a. Ptr a
nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Drawable
rootbg <- Ptr Drawable -> IO Drawable
forall a. Storable a => Ptr a -> IO a
peek (Ptr CUChar -> Ptr Drawable
forall a b. Ptr a -> Ptr b
castPtr Ptr CUChar
prop) :: IO Pixmap
          Ptr CUChar -> IO CInt
forall a. Ptr a -> IO CInt
xFree Ptr CUChar
prop
          Display -> Drawable -> (Drawable -> IO ()) -> IO ()
forall a. Display -> Drawable -> (Drawable -> IO a) -> IO ()
withRenderPicture Display
d Drawable
rootbg ((Drawable -> IO ()) -> IO ()) -> (Drawable -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Drawable
bgpic ->
            Display -> XRenderColor -> (Drawable -> IO ()) -> IO ()
forall a. Display -> XRenderColor -> (Drawable -> 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))
                           (CInt -> Drawable -> Drawable -> Drawable -> IO ()
render CInt
pictOpAdd Drawable
bgpic Drawable
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 :: Drawable
colormap = Display -> Dimension -> Drawable
defaultColormap Display
d (Display -> Dimension
defaultScreen Display
d)
    Color Drawable
_ Word16
red Word16
green Word16
blue Word8
_ <- Display -> Drawable -> String -> IO Color
parseColor Display
d Drawable
colormap String
c
    XRenderColor -> IO XRenderColor
forall (m :: * -> *) a. Monad m => a -> m a
return (XRenderColor -> IO XRenderColor)
-> XRenderColor -> IO XRenderColor
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> XRenderColor
XRenderColor (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
red)
                          (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
green)
                          (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
blue)
                          Int
0xFFFF

pictOpSrc, pictOpAdd :: PictOp
pictOpSrc :: CInt
pictOpSrc = CInt
1
pictOpAdd :: CInt
pictOpAdd = CInt
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