summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Xmobar/X11/Bitmap.hs5
-rw-r--r--src/Xmobar/X11/CairoDraw.hs113
-rw-r--r--src/Xmobar/X11/Draw.hs27
-rw-r--r--src/Xmobar/X11/Loop.hs11
-rw-r--r--src/Xmobar/X11/XlibDraw.hs12
5 files changed, 98 insertions, 70 deletions
diff --git a/src/Xmobar/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs
index 2aea470..026cd5c 100644
--- a/src/Xmobar/X11/Bitmap.hs
+++ b/src/Xmobar/X11/Bitmap.hs
@@ -53,8 +53,9 @@ data Bitmap = Bitmap { width :: Dimension
, bitmapType :: BitmapType
}
-updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath ->
- [[(Widget, TextRenderInfo, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap)
+updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath
+ -> [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
+ -> IO (Map FilePath Bitmap)
updateCache dpy win cache iconRoot ps = do
let paths = map (\(Icon p, _, _, _) -> p) . concatMap (filter icons) $ ps
icons (Icon _, _, _, _) = True
diff --git a/src/Xmobar/X11/CairoDraw.hs b/src/Xmobar/X11/CairoDraw.hs
index 4ed8d84..9dac493 100644
--- a/src/Xmobar/X11/CairoDraw.hs
+++ b/src/Xmobar/X11/CairoDraw.hs
@@ -16,6 +16,9 @@
module Xmobar.X11.CairoDraw (drawInPixmap) where
+import Prelude hiding (lookup)
+import Data.Map (lookup)
+
import Control.Monad.IO.Class
import Control.Monad.Reader
@@ -33,21 +36,45 @@ import Xmobar.Run.Actions (Action)
import Xmobar.Config.Types
import Xmobar.Text.Pango (fixXft)
import Xmobar.X11.Types
+import qualified Xmobar.X11.Bitmap as B
import Xmobar.X11.CairoSurface
type ActionPos = ([Action], Position, Position)
type Actions = [ActionPos]
-type LayoutInfo = (Segment, P.PangoLayout, Double, Double)
-
-drawInPixmap :: Pixmap -> Dimension -> Dimension -> [[Segment]] -> X Actions
-drawInPixmap p w h s = do
+type Renderinfo = (Segment, Surface -> Double -> IO (), Double)
+type BitmapDrawer = Double -> Double -> String -> IO ()
+
+data DrawContext = DC { dcBitmapDrawer :: BitmapDrawer
+ , dcBitmapLookup :: String -> Maybe B.Bitmap
+ , dcConfig :: Config
+ , dcWidth :: Double
+ , dcHeight :: Double
+ , dcSegments :: [[Segment]]
+ }
+
+drawInPixmap :: GC -> Pixmap -> [[Segment]] -> X Actions
+drawInPixmap gc p s = do
xconf <- ask
let disp = display xconf
vis = defaultVisualOfScreen (defaultScreenOfDisplay disp)
- c = config xconf
- fi = fromIntegral
- render = renderSegments c w h s
- liftIO $ withXlibSurface disp p vis (fi w) (fi h) render
+ (Rectangle _ _ w h) = rect xconf
+ dw = fromIntegral w
+ dh = fromIntegral h
+ dc = DC (drawXBitmap xconf gc p) (lookupXBitmap xconf) (config xconf) dw dh s
+ render = renderSegments dc
+ liftIO $ withXlibSurface disp p vis (fromIntegral w) (fromIntegral h) render
+
+lookupXBitmap :: XConf -> String -> Maybe B.Bitmap
+lookupXBitmap xconf path = lookup path (iconS xconf)
+
+drawXBitmap :: XConf -> GC -> Pixmap -> BitmapDrawer
+drawXBitmap xconf gc p h v path = do
+ let disp = display xconf
+ conf = config xconf
+ fc = fgColor conf
+ bc = bgColor conf
+ bm = lookupXBitmap xconf path
+ liftIO $ maybe (return ()) (B.drawBitmap disp p gc fc bc (round h) (round v)) bm
segmentMarkup :: Config -> Segment -> String
segmentMarkup conf (Text txt, info, idx, _actions) =
@@ -58,31 +85,39 @@ segmentMarkup conf (Text txt, info, idx, _actions) =
in P.markSpan attrs' $ P.escapeMarkup txt
segmentMarkup _ _ = ""
-withLayoutInfo :: P.PangoContext -> Double -> Config -> Segment -> IO LayoutInfo
-withLayoutInfo ctx maxh conf seg@(Text _, inf, idx, a) = do
+withRenderinfo :: P.PangoContext -> DrawContext -> Segment -> IO Renderinfo
+withRenderinfo ctx dctx seg@(Text _, inf, idx, a) = do
+ let conf = dcConfig dctx
lyt <- P.layoutEmpty ctx
mk <- P.layoutSetMarkup lyt (segmentMarkup conf seg) :: IO String
(_, P.PangoRectangle o u w h) <- P.layoutGetExtents lyt
let voff' = fromIntegral $ indexedOffset conf idx
- voff = voff' + (maxh - h + u) / 2.0
- return ((Text mk, inf, idx, a), lyt, w - o, voff)
-
-withLayoutInfo ctx _ _ seg = do
- lyt <- P.layoutEmpty ctx
- let n = case seg of (Hspace w, _, _, _) -> w; _ -> 0
- return (seg, lyt, fromIntegral n, 0)
-
-renderLayout :: Surface -> Double -> (Double, Actions)
- -> LayoutInfo -> IO (Double, Actions)
-renderLayout surface maxoff (off, actions) (segment, lyt, lwidth, voff) =
+ voff = voff' + (dcHeight dctx - h + u) / 2.0
+ slyt s pos = C.renderWith s $ C.moveTo pos voff >> P.showLayout lyt
+ return ((Text mk, inf, idx, a), slyt, w - o)
+
+withRenderinfo _ _ seg@(Hspace w, _, _, _) = do
+ return (seg, \_ _ -> return (), fromIntegral w)
+
+withRenderinfo _ dctx seg@(Icon p, _, idx, _) = do
+ let bm = dcBitmapLookup dctx p
+ wd = maybe 0 (fromIntegral . B.width) bm
+ ioff = indexedOffset (dcConfig dctx) idx
+ vpos = dcHeight dctx / 2 - fromIntegral ioff
+ draw _ off = dcBitmapDrawer dctx off vpos p
+ return (seg, draw, wd)
+
+renderSegment ::
+ Surface -> Double -> (Double, Actions) -> Renderinfo -> IO (Double, Actions)
+renderSegment surface maxoff (off, acts) (segment, render, lwidth) =
if off + lwidth > maxoff
- then pure (off, actions)
+ then pure (off, acts)
else do
- C.renderWith surface $ C.moveTo off voff >> P.showLayout lyt
+ render surface off
let end = round $ off + lwidth
(_, _, _, a) = segment
- actions' = case a of Just as -> (as, round off, end):actions; _ -> actions
- return (off + lwidth, actions')
+ acts' = case a of Just as -> (as, round off, end):acts; _ -> acts
+ return (off + lwidth, acts')
setSourceColor :: RGBS.Colour Double -> C.Render ()
setSourceColor = RGBS.uncurryRGB C.setSourceRGB . SRGB.toSRGB
@@ -130,27 +165,27 @@ renderBorder conf w h surf =
NoBorder -> return ()
_ -> C.renderWith surf (outerBorder conf w h)
-layoutsWidth :: [(Segment, P.PangoLayout, Double, Double)] -> Double
-layoutsWidth = foldl (\a (_,_,w,_) -> a + w) 0
+layoutsWidth :: [Renderinfo] -> Double
+layoutsWidth = foldl (\a (_,_,w) -> a + w) 0
-renderSegments ::
- Config -> Dimension -> Dimension -> [[Segment]] -> Surface -> IO Actions
-renderSegments conf w h segments surface = do
- let [left, center, right] = take 3 segments
- dh = fromIntegral h
- dw = fromIntegral w
+renderSegments :: DrawContext -> Surface -> IO Actions
+renderSegments dctx surface = do
+ let [left, center, right] = take 3 $ dcSegments dctx
+ dh = dcHeight dctx
+ dw = dcWidth dctx
+ conf = dcConfig dctx
ctx <- P.cairoCreateContext Nothing
- llyts <- mapM (withLayoutInfo ctx dh conf) left
- rlyts <- mapM (withLayoutInfo ctx dh conf) right
- clyts <- mapM (withLayoutInfo ctx dh conf) center
+ llyts <- mapM (withRenderinfo ctx dctx) left
+ rlyts <- mapM (withRenderinfo ctx dctx) right
+ clyts <- mapM (withRenderinfo ctx dctx) center
renderBackground conf surface
- (lend, as) <- foldM (renderLayout surface dw) (0, []) llyts
+ (lend, as) <- foldM (renderSegment surface dw) (0, []) llyts
let rw = layoutsWidth rlyts
rstart = max (lend + 1) (dw - rw - 1)
cmax = rstart - 1
cw = layoutsWidth clyts
cstart = lend + 1 + max 0 (dw - rw - lend - cw) / 2.0
- (_, as') <- foldM (renderLayout surface cmax) (cstart, as) clyts
- (_, as'') <- foldM (renderLayout surface dw) (rstart, as') rlyts
+ (_, as') <- foldM (renderSegment surface cmax) (cstart, as) clyts
+ (_, as'') <- foldM (renderSegment surface dw) (rstart, as') rlyts
when (borderWidth conf > 0) (renderBorder conf dw dh surface)
return as''
diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs
index 2d61b67..7642afc 100644
--- a/src/Xmobar/X11/Draw.hs
+++ b/src/Xmobar/X11/Draw.hs
@@ -37,33 +37,28 @@ import Xmobar.X11.XlibDraw
#endif
-- | Draws in and updates the window
-#ifdef CAIRO
-drawInWin :: Rectangle -> [[Segment]] -> X [([Action], Position, Position)]
-drawInWin (Rectangle _ _ wid ht) segments = do
-#else
-drawInWin :: XConf -> Rectangle -> [[Segment]] -> X [([Action], Position, Position)]
-drawInWin conf bound@(Rectangle _ _ wid ht) segments = do
-#endif
- r <- ask
- let d = display r
- w = window r
-
+drawInWin :: [[Segment]] -> X [([Action], Position, Position)]
+drawInWin segments = do
+ xconf <- ask
+ let d = display xconf
+ w = window xconf
+ (Rectangle _ _ wid ht) = rect xconf
depth = defaultDepthOfScreen (defaultScreenOfDisplay d)
p <- liftIO $ createPixmap d w wid ht depth
gc <- liftIO $ createGC d w
liftIO $ setGraphicsExposures d gc False
#if defined(XFT) || defined(CAIRO)
- let xconf = config r
- alph = alpha xconf
+ let cconf = config xconf
+ alph = alpha cconf
when (alph < 255)
- (liftIO $ drawBackground d p (bgColor xconf) alph (Rectangle 0 0 wid ht))
+ (liftIO $ drawBackground d p (bgColor cconf) alph (Rectangle 0 0 wid ht))
#endif
#ifdef CAIRO
- res <- drawInPixmap p wid ht segments
+ res <- drawInPixmap gc p segments
#else
- res <- liftIO $ updateActions conf bound segments
+ res <- updateActions (rect xconf) segments
drawInPixmap gc p wid ht segments
#endif
-- copy the pixmap with the new string to the window
diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs
index c6a4e97..8f74b79 100644
--- a/src/Xmobar/X11/Loop.hs
+++ b/src/Xmobar/X11/Loop.hs
@@ -112,6 +112,7 @@ x11EventLoop w signal =
_ -> return ()
-- | Continuously wait for a signal from a thread or an interrupt handler
+-- The list of actions provide also the positions of clickable rectangles
signalLoop :: XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
@@ -121,14 +122,10 @@ signalLoop xc@(XConf d r w fs vos is cfg) as signal tv = do
typ <- atomically $ takeTMVar signal
case typ of
Wakeup -> do
- str <- updateSegments cfg tv
- xc' <- updateCache d w is (iconRoot cfg) str >>=
+ segs <- updateSegments cfg tv
+ xc' <- updateCache d w is (iconRoot cfg) segs >>=
\c -> return xc { iconS = c }
-#ifdef CAIRO
- as' <- runX xc' $ drawInWin r str
-#else
- as' <- runX xc' $ drawInWin xc r str
-#endif
+ as' <- runX xc' $ drawInWin segs
signalLoop xc' as' signal tv
Reposition ->
diff --git a/src/Xmobar/X11/XlibDraw.hs b/src/Xmobar/X11/XlibDraw.hs
index 9483c16..77de23b 100644
--- a/src/Xmobar/X11/XlibDraw.hs
+++ b/src/Xmobar/X11/XlibDraw.hs
@@ -262,9 +262,9 @@ drawBoxBorder
_ -> error "unreachable code"
-updateActions :: XConf -> Rectangle -> [[Segment]]
- -> IO [([Action], Position, Position)]
-updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
+updateActions :: Rectangle -> [[Segment]] -> X [([Action], Position, Position)]
+updateActions (Rectangle _ _ wid _) ~[left,center,right] = do
+ conf <- ask
let d = display conf
fs = fontListS conf
strLn :: [Segment] -> IO [(Maybe [Action], Position, Position)]
@@ -286,6 +286,6 @@ updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
C -> (remWidth xs + offs) `div` 2
R -> remWidth xs
L -> offs
- fmap concat $ mapM (\(a,xs) ->
- (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $
- zip [L,C,R] [left,center,right]
+ liftIO $ fmap concat $ mapM (\(a,xs) ->
+ (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $
+ zip [L,C,R] [left,center,right]