cairo: alpha (still pseudo, via xrender)

5 files changed, 160 insertions, 126 deletions

diff --git a/src/Xmobar/X11/CairoDraw.hs b/src/Xmobar/X11/CairoDraw.hs
index 464dfa3..32adac2 100644
--- a/src/Xmobar/X11/CairoDraw.hs
+++ b/src/Xmobar/X11/CairoDraw.hs
@@ -53,8 +53,9 @@ segmentMarkup :: Config -> Segment -> String
 segmentMarkup conf (Text txt, info, idx, _actions) =
   let fnt = fixXft $ indexedFont conf idx
       (fg, bg) = colorComponents conf (tColorsString info)
-      attrs = [P.FontDescr fnt, P.FontForeground fg, P.FontBackground bg]
-  in P.markSpan attrs $ P.escapeMarkup txt
+      attrs = [P.FontDescr fnt, P.FontForeground fg]
+      attrs' = if bg == bgColor conf then attrs else P.FontBackground bg:attrs
+  in P.markSpan attrs' $ P.escapeMarkup txt
 segmentMarkup _ _ = ""
 
 withLayoutInfo :: P.PangoContext -> Double -> Config -> Segment -> IO LayoutInfo
@@ -86,21 +87,21 @@ renderLayout surface maxoff (off, actions) (segment, lyt, lwidth, voff) =
 setSourceColor :: RGBS.Colour Double -> C.Render ()
 setSourceColor = RGBS.uncurryRGB C.setSourceRGB . SRGB.toSRGB
 
-background :: Config -> SRGB.Colour Double -> C.Render ()
-background conf colour = do
-  setSourceColor colour
-  C.paintWithAlpha $ (fromIntegral (alpha conf)) / 255.0
-
 readColourName :: String -> IO (RGBS.Colour Double)
 readColourName str = do
   case CNames.readColourName str of
     Just c -> return c
     Nothing -> return $ SRGB.sRGB24read str
 
+background :: Config -> SRGB.Colour Double -> C.Render ()
+background conf colour = do
+  setSourceColor colour
+  C.paintWithAlpha $ (fromIntegral (alpha conf)) / 255.0
+
 renderBackground :: Config -> Surface -> IO ()
 renderBackground conf surface = do
-  col <- readColourName (bgColor conf)
-  C.renderWith surface (background conf col)
+  when (alpha conf >= 255)
+    (readColourName (bgColor conf) >>= C.renderWith surface . background conf)
 
 drawRect :: String -> Double -> (Double, Double, Double, Double) -> C.Render()
 drawRect name wd (x0, y0, x1, y1) = do
diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs
index ea7fa95..643ec13 100644
--- a/src/Xmobar/X11/Draw.hs
+++ b/src/Xmobar/X11/Draw.hs
@@ -24,9 +24,11 @@ import Control.Monad.Reader
 
 import Graphics.X11.Xlib hiding (Segment)
 
+import Xmobar.Config.Types
 import Xmobar.Run.Parsers (Segment)
 import Xmobar.Run.Actions (Action)
 import Xmobar.X11.Types
+import Xmobar.X11.XRender (drawBackground)
 
 #ifdef CAIRO
 import Xmobar.X11.CairoDraw
@@ -45,10 +47,19 @@ drawInWin conf bound@(Rectangle _ _ wid ht) segments = do
   r <- ask
   let d = display r
       w = window r
+
       depth = defaultDepthOfScreen (defaultScreenOfDisplay d)
   p <- liftIO $ createPixmap d w wid ht depth
   gc <- liftIO $ createGC d w
   liftIO $ setGraphicsExposures d gc False
+
+#if defined(XFT) || defined(CAIRO)
+  let conf = config r
+      alph = alpha conf
+  when (alph < 255)
+     (liftIO $ drawBackground d p (bgColor conf) alph (Rectangle 0 0 wid ht))
+#endif
+
 #ifdef CAIRO
   res <- drawInPixmap p wid ht segments
 #else
diff --git a/src/Xmobar/X11/MinXft.hsc b/src/Xmobar/X11/MinXft.hsc
index e593da0..e485488 100644
--- a/src/Xmobar/X11/MinXft.hsc
+++ b/src/Xmobar/X11/MinXft.hsc
@@ -1,7 +1,7 @@
 ------------------------------------------------------------------------------
 -- |
 -- Module: MinXft
--- Copyright: (c) 2012, 2014, 2015, 2017 Jose Antonio Ortega Ruiz
+-- Copyright: (c) 2012, 2014, 2015, 2017, 2022 Jose Antonio Ortega Ruiz
 --            (c) Clemens Fruhwirth <clemens@endorphin.org> 2007
 -- License: BSD3-style (see LICENSE)
 --
@@ -28,7 +28,6 @@ module Xmobar.X11.MinXft ( AXftColor
               , withAXftDraw
               , drawXftString
               , drawXftString'
-              , drawBackground
               , drawXftRect
               , openAXftFont
               , closeAXftFont
@@ -47,7 +46,6 @@ 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
@@ -55,8 +53,6 @@ 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
@@ -224,110 +220,3 @@ 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 =
-        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
diff --git a/src/Xmobar/X11/XRender.hsc b/src/Xmobar/X11/XRender.hsc
new file mode 100644
index 0000000..5ad0391
--- /dev/null
+++ b/src/Xmobar/X11/XRender.hsc
@@ -0,0 +1,138 @@
+------------------------------------------------------------------------------
+-- |
+-- 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
+
+#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 =
+        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
diff --git a/src/Xmobar/X11/XlibDraw.hs b/src/Xmobar/X11/XlibDraw.hs
index 5525b70..9483c16 100644
--- a/src/Xmobar/X11/XlibDraw.hs
+++ b/src/Xmobar/X11/XlibDraw.hs
@@ -63,11 +63,6 @@ drawInPixmap gc p wid ht ~[left,center,right] = do
       getWidth (Hspace s,cl,i,_) = return (Hspace s,cl,i,fi s)
       fillBackground clr = setForeground d gc clr >> fillRectangle d p gc 0 0 wid ht
 
-#if XFT
-  when (alpha c /= 255)
-     (liftIO $ drawBackground d p (bgColor c) (alpha c) (Rectangle 0 0 wid ht))
-#endif
-
   withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do
 #if XFT
     when (alpha c == 255) $ liftIO (fillBackground bgcolor)