{-# 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 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" #-}

-- | 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
    format <- Display -> PictOp -> IO (Ptr XRenderPictFormat)
xRenderFindStandardFormat Display
d PictOp
1 -- PictStandardRGB24
    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

-- | 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
    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

-- | 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 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
    -- Handle background color
    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)
    -- Handle transparency
    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)

-- | 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 -> 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

-- 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