Merge branch 'transparency' of https://github.com/ezyang/xmobar

Conflicts:
	src/Config.hs
	src/Main.hs
	src/Parsers.hs
	src/XUtil.hsc
	src/Xmobar.hs

5 files changed, 148 insertions, 15 deletions

diff --git a/src/Config.hs b/src/Config.hs
index 7e43e92..ee58a92 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -57,6 +57,7 @@ data Config =
            , border :: Border       -- ^ NoBorder TopB BottomB or FullB
            , borderColor :: String  -- ^ Border color
            , borderWidth :: Int     -- ^ Border width
+           , alpha :: Int           -- ^ Transparency from 0 (transparent) to 255 (opaque)
            , hideOnStart :: Bool    -- ^ Hide (Unmap) the window on
                                     --   initialization
            , allDesktops :: Bool    -- ^ Tell the WM to map to all desktops
@@ -111,6 +112,7 @@ defaultConfig =
     Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
            , bgColor = "#000000"
            , fgColor = "#BFBFBF"
+           , alpha   = 0
            , position = Top
            , border = NoBorder
            , borderColor = "#BFBFBF"
diff --git a/src/Main.hs b/src/Main.hs
index 5266cd1..4146c1c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -121,6 +121,7 @@ data Opts = Help
           | Font       String
           | BgColor    String
           | FgColor    String
+          | Alpha      String
           | T
           | B
           | D
@@ -144,6 +145,8 @@ options =
       "The foreground color. Default grey"
     , Option "i" ["iconroot"] (ReqArg IconRoot "path")
       "Root directory for icon pattern paths. Default '.'"
+    , Option "a" ["alpha"] (ReqArg Alpha "alpha")
+      "The transparency: 0 is transparent, 255 is opaque"
     , Option "o" ["top"] (NoArg T) "Place xmobar at the top of the screen"
     , Option "b" ["bottom"] (NoArg B)
       "Place xmobar at the bottom of the screen"
@@ -200,6 +203,7 @@ doOpts conf (o:oo) =
     Font s -> doOpts' (conf {font = s})
     BgColor s -> doOpts' (conf {bgColor = s})
     FgColor s -> doOpts' (conf {fgColor = s})
+    Alpha n -> doOpts' (conf {alpha = read n})
     T -> doOpts' (conf {position = Top})
     B -> doOpts' (conf {position = Bottom})
     D -> doOpts' (conf {overrideRedirect = False})
diff --git a/src/Parsers.hs b/src/Parsers.hs
index cdc180d..d2fa1bf 100644
--- a/src/Parsers.hs
+++ b/src/Parsers.hs
@@ -199,8 +199,8 @@ parseConfig = runParser parseConf fields "Config" . stripComments
 
       perms = permute $ Config
               <$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition
-              <|?> pTextOffset <|?> pIconOffset
-              <|?> pBorder <|?> pBdColor <|?> pBdWidth <|?> pHideOnStart
+              <|?> pTextOffset <|?> pIconOffset <|?> pBorder
+              <|?> pBdColor <|?> pBdWidth <|?> pAlpha <|?> pHideOnStart
               <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest
               <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot
               <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate
@@ -211,7 +211,7 @@ parseConfig = runParser parseConf fields "Config" . stripComments
                   , "textOffset", "iconOffset"
                   , "allDesktops", "overrideRedirect", "pickBroadest"
                   , "hideOnStart", "lowerOnStart", "persistent", "iconRoot"
-                  , "commands"
+                  , "alpha", "commands"
                   ]
 
       pFont = strField font "font"
@@ -234,6 +234,7 @@ parseConfig = runParser parseConf fields "Config" . stripComments
       pOverrideRedirect = readField overrideRedirect "overrideRedirect"
       pPickBroadest = readField pickBroadest "pickBroadest"
       pIconRoot = readField iconRoot "iconRoot"
+      pAlpha = readField alpha "alpha"
 
       pCommands = field commands "commands" readCommands
 
diff --git a/src/XUtil.hsc b/src/XUtil.hsc
index f7b36ca..e333a22 100644
--- a/src/XUtil.hsc
+++ b/src/XUtil.hsc
@@ -26,6 +26,35 @@ module XUtil
     , hGetLineSafe
     , io
     , fi
+    , XRenderPictureAttributes(..)
+    , XRenderPictFormat(..)
+    , XRenderColor(..) -- reexport
+    , Picture
+    , xRenderFindStandardFormat
+    , xRenderCreatePicture
+    , xRenderFillRectangle
+    , xRenderComposite
+    , xRenderCreateSolidFill
+    , xRenderFreePicture
+    , withRenderPicture
+    , withRenderFill
+    , parseRenderColor
+    , pictOpMinimum
+    , pictOpClear
+    , pictOpSrc
+    , pictOpDst
+    , pictOpOver
+    , pictOpOverReverse
+    , pictOpIn
+    , pictOpInReverse
+    , pictOpOut
+    , pictOpOutReverse
+    , pictOpAtop
+    , pictOpAtopReverse
+    , pictOpXor
+    , pictOpAdd
+    , pictOpSaturate
+    , pictOpMaximum
     ) where
 
 import Control.Concurrent
@@ -38,6 +67,7 @@ import Graphics.X11.Xlib.Extras
 import System.Mem.Weak ( addFinalizer )
 import System.Posix.Types (Fd(..))
 import System.IO
+import Foreign.C
 
 #if defined XFT || defined UTF8
 # if __GLASGOW_HASKELL__ < 612
@@ -165,15 +195,13 @@ printString :: Display -> Drawable -> XFont -> GC -> String -> String
             -> Position -> Position -> String  -> IO ()
 printString d p (Core fs) gc fc bc x y s = do
     setFont d gc $ fontFromFontStruct fs
-    withColors d [fc, bc] $ \[fc', bc'] -> do
+    withColors d [fc, bc] $ \[fc', _] -> do
       setForeground d gc fc'
-      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', bc'] -> do
+    withColors d [fc, bc] $ \[fc', _] -> do
       setForeground d gc fc'
-      setBackground d gc bc'
       io $ wcDrawImageString d p fs gc x y s
 
 #ifdef XFT
@@ -181,10 +209,6 @@ printString dpy drw fs@(Xft fonts) _ fc bc x y s = do
   (a,d)  <- textExtents fs s
   gi <- xftTxtExtents' dpy fonts s
   withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' ->
-    (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
 
@@ -230,3 +254,79 @@ setupLocale = withCString "" (setlocale $ #const LC_ALL) >> return ()
 setupLocale :: IO ()
 setupLocale = return ()
 #endif
+
+--  More XRender nonsense
+#include <X11/extensions/Xrender.h>
+
+type Picture = XID
+type PictOp = CInt
+
+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
+
+data XRenderPictFormat = XRenderPictFormat
+data XRenderPictureAttributes = XRenderPictureAttributes
+
+-- 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
+
+-- | 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
+
+pictOpMinimum, pictOpClear, pictOpSrc, pictOpDst, pictOpOver, pictOpOverReverse,
+    pictOpIn, pictOpInReverse, pictOpOut, pictOpOutReverse, pictOpAtop,
+    pictOpAtopReverse, pictOpXor, pictOpAdd, pictOpSaturate, pictOpMaximum :: PictOp
+pictOpMinimum = 0
+pictOpClear = 0
+pictOpSrc = 1
+pictOpDst = 2
+pictOpOver = 3
+pictOpOverReverse = 4
+pictOpIn = 5
+pictOpInReverse = 6
+pictOpOut = 7
+pictOpOutReverse = 8
+pictOpAtop = 9
+pictOpAtopReverse = 10
+pictOpXor = 11
+pictOpAdd = 12
+pictOpSaturate = 13
+pictOpMaximum = 13
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 459d6ef..3016f75 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -44,6 +44,9 @@ 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
@@ -283,14 +286,37 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
       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)
 
-  withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do
+  withColors d [borderColor c] $ \[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))
-    -- the fgcolor of the rectangle will be the bgcolor of the window
-    io $ setForeground d gc bgcolor
-    io $ fillRectangle d p gc 0 0 wid ht
+    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)) $ \m ->
+                xRenderComposite d pictOpSrc bgfill m pic 0 0 0 0 0 0 (fromIntegral wid) (fromIntegral ht)
+        -- 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)) $ \m ->
+                            xRenderComposite d pictOpAdd bgpic m pic 0 0 0 0 0 0 (fromIntegral wid) (fromIntegral ht)
     -- write to the pixmap the new string
     printStrings p gc fs 1 L =<< strLn left
     printStrings p gc fs 1 R =<< strLn right