diff options
Diffstat (limited to 'src/Xmobar/X11')
| -rw-r--r-- | src/Xmobar/X11/Bitmap.hs | 5 | ||||
| -rw-r--r-- | src/Xmobar/X11/CairoDraw.hs | 113 | ||||
| -rw-r--r-- | src/Xmobar/X11/Draw.hs | 27 | ||||
| -rw-r--r-- | src/Xmobar/X11/Loop.hs | 11 | ||||
| -rw-r--r-- | src/Xmobar/X11/XlibDraw.hs | 12 |
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] |