diff options
| -rw-r--r-- | src/XUtil.hsc | 65 | ||||
| -rw-r--r-- | src/Xmobar.hs | 59 |
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 |