summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/X11/CairoDraw.hs
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2022-09-10 04:33:56 +0100
committerjao <jao@gnu.org>2022-09-10 04:33:56 +0100
commitb2d0d19c4b3d33ea336e78c62e7eddfa805281ac (patch)
tree2b42db25b82ffa3e23f702bb0bbb9d19673ff541 /src/Xmobar/X11/CairoDraw.hs
parentf81a7cfef463907ba4b68cb1352a869960350685 (diff)
downloadxmobar-b2d0d19c4b3d33ea336e78c62e7eddfa805281ac.tar.gz
xmobar-b2d0d19c4b3d33ea336e78c62e7eddfa805281ac.tar.bz2
cairo: fonts, offsets, colors, actions
Diffstat (limited to 'src/Xmobar/X11/CairoDraw.hs')
-rw-r--r--src/Xmobar/X11/CairoDraw.hs71
1 files changed, 57 insertions, 14 deletions
diff --git a/src/Xmobar/X11/CairoDraw.hs b/src/Xmobar/X11/CairoDraw.hs
index 424ea90..527b68a 100644
--- a/src/Xmobar/X11/CairoDraw.hs
+++ b/src/Xmobar/X11/CairoDraw.hs
@@ -20,29 +20,72 @@ import Control.Monad.IO.Class
import Control.Monad.Reader
import Graphics.X11.Xlib hiding (Segment)
-import GI.Cairo.Render.Types
+import Graphics.Rendering.Cairo.Types
+import qualified Graphics.Rendering.Cairo as C
+import qualified Graphics.Rendering.Pango as P
-import Xmobar.Run.Parsers (Segment)
+import qualified Data.Colour.SRGB as SRGB
+import qualified Data.Colour.Names as CNames
+import qualified Data.Colour.RGBSpace as RGBS
+
+import Xmobar.Run.Parsers (Segment, Widget(..), colorComponents, tColorsString)
+import Xmobar.Run.Actions (Action)
+import Xmobar.Config.Types
+import Xmobar.Text.Pango (fixXft)
import Xmobar.X11.Types
import Xmobar.X11.CairoSurface
--- import Xmobar.Text.Pango
-import Xmobar.Config.Types
-drawInPixmap :: Pixmap -> Dimension -> Dimension -> [[Segment]] -> X ()
+type ActionPos = ([Action], Position, Position)
+type Actions = [ActionPos]
+
+drawInPixmap :: Pixmap -> Dimension -> Dimension -> [[Segment]] -> X Actions
drawInPixmap p w h s = do
xconf <- ask
let disp = display xconf
- scr = screenOfDisplay disp 0
+ vis = defaultVisualOfScreen (defaultScreenOfDisplay disp)
c = config xconf
fi = fromIntegral
- liftIO $ withBitmapSurface disp p scr (fi w) (fi h) (renderSegments c s)
+ render = (renderSegments c w h s)
+ liftIO $ withXlibSurface disp p vis (fi w) (fi h) render
+
+withMarkup :: Config -> Segment -> String
+withMarkup conf (Text txt, info, idx, _actions) =
+ let fnt = fixXft $ indexedFont conf idx
+ (fg, bg) = colorComponents conf (tColorsString info)
+ attrs = [P.FontDescr fnt, P.FontForeground fg, P.FontBackground bg]
+ in P.markSpan attrs $ P.escapeMarkup txt
+withMarkup _ _ = ""
+
+type FPair = (Position, Actions)
+
+renderSegment ::
+ Double -> Config -> Surface -> P.PangoLayout -> FPair -> Segment -> IO FPair
+renderSegment mh conf surface lyt (offset,actions) seg@(Text _, _, idx, a) = do
+ _ <- (P.layoutSetMarkup lyt (withMarkup conf seg)) :: IO String
+ (_, P.PangoRectangle o u w h) <- P.layoutGetExtents lyt
+ let voff' = fromIntegral $ indexedOffset conf idx
+ voff = voff' + (mh - h + u) / 2.0
+ hoff = fromIntegral offset
+ C.renderWith surface $ C.moveTo hoff voff >> P.showLayout lyt
+ let end = round $ hoff + o + w
+ actions' = case a of Just as -> (as, offset, end):actions; _ -> actions
+ return (end, actions')
+renderSegment _h _c _surface _lyt acc _segment = pure acc
-renderSegment :: String -> String -> Surface -> Segment -> IO ()
-renderSegment _fg _bg _surface _segment = undefined
+background :: Config -> SRGB.Colour Double -> C.Render ()
+background conf colour = do
+ RGBS.uncurryRGB C.setSourceRGB (SRGB.toSRGB colour)
+ C.paintWithAlpha $ (fromIntegral (alpha conf)) / 255.0
-renderSegments :: Config -> [[Segment]] -> Surface -> IO ()
-renderSegments conf segments surface = do
- let bg = bgColor conf
- fg = fgColor conf
- mapM_ (renderSegment fg bg surface) (concat segments)
+renderSegments ::
+ Config -> Dimension -> Dimension -> [[Segment]] -> Surface -> IO Actions
+renderSegments conf _w h segments surface = do
+ ctx <- P.cairoCreateContext Nothing
+ lyt <- P.layoutEmpty ctx
+ col <- case CNames.readColourName (bgColor conf) of
+ Just c -> return c
+ Nothing -> return $ SRGB.sRGB24read (bgColor conf)
+ C.renderWith surface (background conf col)
+ let dh = fromIntegral h
+ snd `fmap` foldM (renderSegment dh conf surface lyt) (0, []) (concat segments)