summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2015-01-07 03:34:56 +0100
committerjao <jao@gnu.org>2015-01-07 03:34:56 +0100
commit850a3e8a8b5f183190d7f34c78b1c7979f916979 (patch)
tree1c2da1c255d650c7c4f265c960a3c7d86fe5e036 /src
parent7abab2215baa99d7d99282f0638989857b11cbf4 (diff)
downloadxmobar-850a3e8a8b5f183190d7f34c78b1c7979f916979.tar.gz
xmobar-850a3e8a8b5f183190d7f34c78b1c7979f916979.tar.bz2
Honoring background color when alpha=255 (issue #209)
Diffstat (limited to 'src')
-rw-r--r--src/XUtil.hsc65
-rw-r--r--src/Xmobar.hs59
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