Real fix: Xrender only available if with_xft

1 files changed, 114 insertions, 2 deletions

diff --git a/src/MinXft.hsc b/src/MinXft.hsc
index b2299af..148efe7 100644
--- a/src/MinXft.hsc
+++ b/src/MinXft.hsc
@@ -1,8 +1,7 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
 ------------------------------------------------------------------------------
 -- |
 -- Module: MinXft
--- Copyright: (c) 2012, 2014 Jose Antonio Ortega Ruiz
+-- Copyright: (c) 2012, 2014, 2015 Jose Antonio Ortega Ruiz
 --            (c) Clemens Fruhwirth <clemens@endorphin.org> 2007
 -- License: BSD3-style (see LICENSE)
 --
@@ -19,6 +18,8 @@
 --
 ------------------------------------------------------------------------------
 
+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
+
 module MinXft ( AXftColor
               , AXftDraw (..)
               , AXftFont
@@ -27,6 +28,7 @@ module MinXft ( AXftColor
               , withAXftDraw
               , drawXftString
               , drawXftString'
+              , drawBackground
               , drawXftRect
               , openAXftFont
               , closeAXftFont
@@ -45,6 +47,7 @@ where
 import Graphics.X11
 import Graphics.X11.Xlib.Types
 import Graphics.X11.Xrender
+import Graphics.X11.Xlib.Extras (xGetWindowProperty, xFree)
 
 import Foreign
 import Foreign.C.Types
@@ -52,6 +55,8 @@ import Foreign.C.String
 import Codec.Binary.UTF8.String as UTF8
 import Data.Char (ord)
 
+import Control.Monad (when)
+
 #include <X11/Xft/Xft.h>
 
 -- Color Handling
@@ -219,3 +224,110 @@ drawXftRect :: (Integral a3, Integral a2, Integral a1, Integral a) =>
                AXftDraw -> AXftColor -> a -> a1 -> a2 -> a3 -> IO ()
 drawXftRect draw color x y width height =
   cXftDrawRect draw color (fi x) (fi y) (fi width) (fi height)
+
+#include <X11/extensions/Xrender.h>
+
+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 _ = #{size XRenderPictureAttributes}
+    alignment _ = alignment (undefined :: CInt)
+    peek _ = return XRenderPictureAttributes
+    poke p XRenderPictureAttributes = do
+        memset p 0 #{size XRenderPictureAttributes}
+
+-- | Convenience function, gives us an XRender handle to a traditional
+-- Pixmap.  Don't let it escape.
+withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO ()
+withRenderPicture d p f = do
+    format <- xRenderFindStandardFormat d 1 -- PictStandardRGB24
+    alloca $ \attr -> do
+        pic <- xRenderCreatePicture d p format 0 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 d c f = do
+    pic <- with c (xRenderCreateSolidFill 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 d p bgc alpha (Rectangle x y wid ht) = do
+  let render opt bg pic m =
+        xRenderComposite d opt bg m pic
+                        (fromIntegral x) (fromIntegral y) 0 0
+                        0 0 (fromIntegral wid) (fromIntegral ht)
+  withRenderPicture d p $ \pic -> do
+    -- Handle background color
+    bgcolor <- parseRenderColor d bgc
+    withRenderFill d bgcolor $ \bgfill ->
+      withRenderFill d
+                     (XRenderColor 0 0 0 (257 * alpha))
+                     (render pictOpSrc bgfill pic)
+    -- Handle transparency
+    internAtom d "_XROOTPMAP_ID" False >>= \xid ->
+      let xroot = defaultRootWindow d in
+      alloca $ \x1 ->
+      alloca $ \x2 ->
+      alloca $ \x3 ->
+      alloca $ \x4 ->
+      alloca $ \pprop -> do
+        xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop
+        prop <- peek pprop
+        when (prop /= nullPtr) $ do
+          rootbg <- peek (castPtr prop) :: IO Pixmap
+          xFree prop
+          withRenderPicture d rootbg $ \bgpic ->
+            withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha))
+                           (render pictOpAdd bgpic pic)
+
+-- | Parses color into XRender color (allocation not necessary!)
+parseRenderColor :: Display -> String -> IO XRenderColor
+parseRenderColor d c = do
+    let colormap = defaultColormap d (defaultScreen d)
+    Color _ red green blue _ <- parseColor d colormap c
+    return $ XRenderColor (fromIntegral red) (fromIntegral green) (fromIntegral blue) 0xFFFF
+
+pictOpSrc, pictOpAdd :: PictOp
+pictOpSrc = 1
+pictOpAdd = 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