diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Config.hs | 2 | ||||
| -rw-r--r-- | src/Main.hs | 5 | ||||
| -rw-r--r-- | src/Parsers.hs | 3 | ||||
| -rw-r--r-- | src/XUtil.hsc | 112 | ||||
| -rw-r--r-- | src/Xmobar.hs | 34 |
5 files changed, 144 insertions, 12 deletions
diff --git a/src/Config.hs b/src/Config.hs index 4f03d93..d785002 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -57,6 +57,7 @@ data Config = , position :: XPosition -- ^ Top Bottom or Static , border :: Border -- ^ NoBorder TopB BottomB or FullB , borderColor :: String -- ^ Border color + , 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 @@ -107,6 +108,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 e90a158..f7a70ff 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -119,6 +119,7 @@ data Opts = Help | Font String | BgColor String | FgColor String + | Alpha String | T | B | D @@ -139,6 +140,8 @@ options = "The background color. Default black" , Option "F" ["fgcolor"] (ReqArg FgColor "fg color") "The foreground color. Default grey" + , 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" @@ -195,6 +198,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}) @@ -215,4 +219,3 @@ doOpts conf (o:oo) = "specified with the -" ++ c:" option\n") readStr str = [x | (x,t) <- reads str, ("","") <- lex t] doOpts' opts = doOpts opts oo - diff --git a/src/Parsers.hs b/src/Parsers.hs index 919ce68..a5869ef 100644 --- a/src/Parsers.hs +++ b/src/Parsers.hs @@ -164,7 +164,7 @@ parseConfig = runParser parseConf fields "Config" . stripComments perms = permute $ Config <$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition - <|?> pBorder <|?> pBdColor <|?> pHideOnStart <|?> pAllDesktops + <|?> pBorder <|?> pBdColor <|?> pAlpha <|?> pHideOnStart <|?> pAllDesktops <|?> pOverrideRedirect <|?> pLowerOnStart <|?> pPersistent <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate @@ -182,6 +182,7 @@ parseConfig = runParser parseConf fields "Config" . stripComments pAlignSep = strField alignSep "alignSep" pTemplate = strField template "template" + pAlpha = readField alpha "alpha" pPosition = readField position "position" pHideOnStart = readField hideOnStart "hideOnStart" pLowerOnStart = readField lowerOnStart "lowerOnStart" diff --git a/src/XUtil.hsc b/src/XUtil.hsc index b1e885c..c3bca7c 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 @@ -157,13 +187,11 @@ printString d p (Core fs) gc fc bc x y s = do setFont d gc $ fontFromFontStruct fs withColors d [fc, bc] $ \[fc', bc'] -> 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 setForeground d gc fc' - setBackground d gc bc' io $ wcDrawImageString d p fs gc x y s #ifdef XFT @@ -171,10 +199,6 @@ printString dpy drw fs@(Xft font) _ fc bc x y s = do (a,d) <- textExtents fs s gi <- xftTxtExtents dpy font 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' font x (y - 2) s) #endif @@ -220,3 +244,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 3cff475..823b594 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -43,6 +43,9 @@ import Control.Exception (handle, SomeException(..)) import Data.Bits import Data.Map hiding (foldr, map, filter) import Data.Maybe (fromJust) +import Foreign.Marshal.Alloc +import Foreign.Storable +import Foreign.Ptr import Bitmap import Config @@ -276,14 +279,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 |