summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--readme.md4
-rw-r--r--src/Config.hs2
-rw-r--r--src/Main.hs4
-rw-r--r--src/Parsers.hs7
-rw-r--r--src/XUtil.hsc116
-rw-r--r--src/Xmobar.hs34
-rw-r--r--xmobar.cabal2
7 files changed, 153 insertions, 16 deletions
diff --git a/readme.md b/readme.md
index 9916108..fcca7f8 100644
--- a/readme.md
+++ b/readme.md
@@ -233,6 +233,9 @@ Other configuration options:
`fgColor`
: Default font color.
+`alpha`
+: The transparency. 0 is transparent, 255 is opaque.
+
`position`
: Top, TopP, TopW, TopSize, Bottom, BottomP, BottomW, BottomSize or Static
(with x, y, width and height).
@@ -374,6 +377,7 @@ xmobar --help):
-f font name --font=font name The font name
-B bg color --bgcolor=bg color The background color. Default black
-F fg color --fgcolor=fg color The foreground color. Default grey
+ -a alpha --alpha=alpha The transparency: 0 is transparent, 255 is opaque
-o --top Place xmobar at the top of the screen
-b --bottom Place xmobar at the bottom of the screen
-d --dock Try to start xmobar as a dock
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
diff --git a/xmobar.cabal b/xmobar.cabal
index 442c504..f63ed3b 100644
--- a/xmobar.cabal
+++ b/xmobar.cabal
@@ -97,7 +97,7 @@ executable xmobar
ghc-prof-options: -prof -auto-all
ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind
- extra-libraries: Xrandr
+ extra-libraries: Xrandr Xrender
build-depends:
base == 4.*,