1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
------------------------------------------------------------------------------
-- |
-- Module: Xmobar.X11.CairoDraw
-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: unportable
-- Created: Fri Sep 09, 2022 02:03
--
-- Drawing the xmobar contents using Cairo and Pango
--
--
------------------------------------------------------------------------------
module Xmobar.X11.CairoDraw (drawInPixmap) where
import Control.Monad.IO.Class
import Control.Monad.Reader
import Graphics.X11.Xlib hiding (Segment)
import Graphics.Rendering.Cairo.Types
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Pango as P
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
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
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
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 _ _ _ _ (offset,actions) (Hspace n, _, _, a) = do
let end = offset + n
actions' = case a of Just as -> (as, offset, end):actions; _ -> actions
return (end, actions')
renderSegment _h _c _surface _lyt acc _segment = pure acc
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 -> 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)
|
