Honoring background color when alpha=255 (issue #209)

2 files changed, 69 insertions, 55 deletions

diff --git a/src/XUtil.hsc b/src/XUtil.hsc
index 2e7e361..d123d4e 100644
--- a/src/XUtil.hsc
+++ b/src/XUtil.hsc
@@ -2,7 +2,7 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XUtil
--- Copyright   :  (C) 2011, 2012, 2013, 2014 Jose Antonio Ortega Ruiz
+-- Copyright   :  (C) 2011, 2012, 2013, 2014, 2015 Jose Antonio Ortega Ruiz
 --                (C) 2007 Andrea Rossato
 -- License     :  BSD3
 --
@@ -38,6 +38,7 @@ module XUtil
     , xRenderFreePicture
     , withRenderPicture
     , withRenderFill
+    , drawBackground
     , parseRenderColor
     , pictOpMinimum
     , pictOpClear
@@ -58,6 +59,7 @@ module XUtil
     ) where
 
 import Control.Concurrent
+import Control.Monad (when)
 import Control.Monad.Trans
 import Control.Exception (SomeException, handle)
 import Foreign
@@ -192,21 +194,28 @@ textExtents (Xft xftfonts) _ = do
 #endif
 
 printString :: Display -> Drawable -> XFont -> GC -> String -> String
-            -> Position -> Position -> String  -> IO ()
-printString d p (Core fs) gc fc bc x y s = do
+            -> Position -> Position -> String -> Int -> IO ()
+printString d p (Core fs) gc fc bc x y s a = do
     setFont d gc $ fontFromFontStruct fs
-    withColors d [fc, bc] $ \[fc', _] -> do
+    withColors d [fc, bc] $ \[fc', bc'] -> do
       setForeground d gc fc'
+      when (a == 255) (setBackground d gc bc')
       drawImageString d p gc x y s
 
-printString d p (Utf8 fs) gc fc bc x y s =
-    withColors d [fc, bc] $ \[fc', _] -> do
+printString d p (Utf8 fs) gc fc bc x y s a =
+    withColors d [fc, bc] $ \[fc', bc'] -> do
       setForeground d gc fc'
+      when (a == 255) (setBackground d gc bc')
       io $ wcDrawImageString d p fs gc x y s
 
 #ifdef XFT
-printString dpy drw (Xft fonts) _ fc bc x y s = do
-  withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \_ ->
+printString dpy drw fs@(Xft fonts) _ fc bc x y s al = do
+  withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' -> do
+    when (al == 255) $ do
+      (a,d)  <- textExtents fs s
+      gi <- xftTxtExtents dpy (head fonts) s
+      drawXftRect draw bc' (x + 1 - fi (xglyphinfo_x gi))
+                  (y - (a + d) + 1) (xglyphinfo_xOff gi) (a + d)
     (drawXftString' draw fc' fonts (toInteger x) (toInteger (y - 2)) s)
 #endif
 
@@ -302,6 +311,38 @@ withRenderFill d c f = do
     f pic
     xRenderFreePicture d pic
 
+-- | Drawing the background to a pixmap and tacking 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
@@ -309,9 +350,11 @@ parseRenderColor d c = do
     Color _ red green blue _ <- parseColor d colormap c
     return $ XRenderColor (fromIntegral red) (fromIntegral green) (fromIntegral blue) 0xFFFF
 
-pictOpMinimum, pictOpClear, pictOpSrc, pictOpDst, pictOpOver, pictOpOverReverse,
-    pictOpIn, pictOpInReverse, pictOpOut, pictOpOutReverse, pictOpAtop,
-    pictOpAtopReverse, pictOpXor, pictOpAdd, pictOpSaturate, pictOpMaximum :: PictOp
+pictOpMinimum, pictOpClear, pictOpSrc,
+  pictOpDst, pictOpOver, pictOpOverReverse,
+  pictOpIn, pictOpInReverse, pictOpOut, pictOpOutReverse, pictOpAtop,
+  pictOpAtopReverse, pictOpXor, pictOpAdd, pictOpSaturate,
+  pictOpMaximum :: PictOp
 pictOpMinimum = 0
 pictOpClear = 0
 pictOpSrc = 1
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 900feaa..022ffd8 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -44,9 +44,6 @@ import Control.Exception (handle, SomeException(..))
 import Data.Bits
 import Data.Map hiding (foldr, map, filter)
 import Data.Maybe (fromJust, isJust)
-import Foreign.Marshal.Alloc
-import Foreign.Storable
-import Foreign.Ptr
 
 import Bitmap
 import Config
@@ -89,7 +86,8 @@ runX :: XConf -> X () -> IO ()
 runX xc f = runReaderT f xc
 
 -- | Starts the main event loop and threads
-startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO ()
+startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]]
+             -> IO ()
 startLoop xcfg@(XConf _ _ w _ _ _) sig vs = do
 #ifdef XFT
     xftInitFtLibrary
@@ -112,8 +110,8 @@ startLoop xcfg@(XConf _ _ w _ _ _) sig vs = do
     eventer signal =
       allocaXEvent $ \e -> do
         dpy <- openDisplay ""
-        xrrSelectInput    dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask
-        selectInput       dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask)
+        xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask
+        selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask)
 
         forever $ do
 #ifdef THREADED_RUNTIME
@@ -277,51 +275,23 @@ updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
 
 -- | Draws in and updates the window
 drawInWin :: Rectangle -> [[(Widget, String, Maybe [Action])]] -> X ()
-drawInWin (Rectangle x y wid ht) ~[left,center,right] = do
+drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do
   r <- ask
-  let (c,d ) = (config &&& display) r
+  let (c,d)  = (config &&& display) r
       (w,fs) = (window &&& fontS  ) r
       strLn  = io . mapM getWidth
       iconW i = maybe 0 Bitmap.width (lookup i $ iconS r)
       getWidth (Text s,cl,_) = textWidth d fs s >>= \tw -> return (Text s,cl,fi tw)
       getWidth (Icon s,cl,_) = return (Icon s,cl,fi $ iconW s)
-      render opt bg pic m =
-        xRenderComposite d opt bg m pic (fromIntegral x) (fromIntegral y)
-                         0 0 0 0 (fromIntegral wid) (fromIntegral ht)
 
-  withColors d [borderColor c] $ \[bdcolor] -> do
+  p <- io $ createPixmap d w wid ht
+                         (defaultDepthOfScreen (defaultScreenOfDisplay d))
+  when (alpha c /= 255) (io $ drawBackground d p (bgColor c) (alpha c) wr)
+  withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do
     gc <- io $ createGC  d w
-    -- create a pixmap to write to and fill it with a rectangle
-    p <- io $ createPixmap d w wid ht
-         (defaultDepthOfScreen (defaultScreenOfDisplay d))
-    io $ withRenderPicture d p $ \pic -> do
-        -- Handle background color
-        bgcolor <- parseRenderColor d (bgColor c)
-        withRenderFill d bgcolor $ \bgfill ->
-            -- I apparently don't know how to do this properly with
-            -- just bgcolor' (putting in the mask alpha directly has strange
-            -- results.  I wish someone had better docs on how
-            -- XRenderComposite worked...)
-            withRenderFill d
-                           (XRenderColor 0 0 0 (257 * alpha c))
-                           (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 c))
-                                 (render pictOpAdd bgpic pic)
+    when (alpha c == 255) $ do
+      io $ setForeground d gc bgcolor
+      io $ fillRectangle d p gc 0 0 wid ht
     -- write to the pixmap the new string
     printStrings p gc fs 1 L =<< strLn left
     printStrings p gc fs 1 R =<< strLn right
@@ -358,6 +328,7 @@ printStrings _ _ _ _ _ [] = return ()
 printStrings dr gc fontst offs a sl@((s,c,l):xs) = do
   r <- ask
   let (conf,d) = (config &&& display) r
+      alph = alpha conf
       Rectangle _ _ wid ht = rect r
       totSLen = foldr (\(_,_,len) -> (+) len) 0 sl
       remWidth = fi wid - fi totSLen
@@ -370,6 +341,6 @@ printStrings dr gc fontst offs a sl@((s,c,l):xs) = do
                  (f,    _) -> (f, bgColor conf)
   valign <- verticalOffset ht s fontst conf
   case s of
-    (Text t) -> io $ printString d dr fontst gc fc bc offset valign t
+    (Text t) -> io $ printString d dr fontst gc fc bc offset valign t alph
     (Icon p) -> io $ maybe (return ()) (drawBitmap d dr gc fc bc offset valign) (lookup p (iconS r))
   printStrings dr gc fontst (offs + l) a xs