cairo: fonts, offsets, colors, actions

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)