diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Config.hs | 2 | ||||
| -rw-r--r-- | src/Main.hs | 4 | ||||
| -rw-r--r-- | src/Parsers.hs | 7 | ||||
| -rw-r--r-- | src/XUtil.hsc | 116 | ||||
| -rw-r--r-- | src/Xmobar.hs | 34 |
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 |