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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
------------------------------------------------------------------------------
-- |
-- 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]
type LayoutInfo = (Segment, P.PangoLayout, Double, Double)
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
segmentMarkup :: Config -> Segment -> String
segmentMarkup 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]
attrs' = if bg == bgColor conf then attrs else P.FontBackground bg:attrs
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
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) =
if off + lwidth > maxoff
then pure (off, actions)
else do
C.renderWith surface $ C.moveTo off voff >> P.showLayout lyt
let end = round $ off + lwidth
(_, _, _, a) = segment
actions' = case a of Just as -> (as, round off, end):actions; _ -> actions
return (off + lwidth, actions')
setSourceColor :: RGBS.Colour Double -> C.Render ()
setSourceColor = RGBS.uncurryRGB C.setSourceRGB . SRGB.toSRGB
readColourName :: String -> IO (RGBS.Colour Double)
readColourName str =
case CNames.readColourName str of
Just c -> return c
Nothing -> return $ SRGB.sRGB24read str
background :: Config -> SRGB.Colour Double -> C.Render ()
background conf colour = do
setSourceColor colour
C.paintWithAlpha $ fromIntegral (alpha conf) / 255.0
renderBackground :: Config -> Surface -> IO ()
renderBackground conf surface =
when (alpha conf >= 255)
(readColourName (bgColor conf) >>= C.renderWith surface . background conf)
drawRect :: String -> Double -> (Double, Double, Double, Double) -> C.Render()
drawRect name wd (x0, y0, x1, y1) = do
col <- liftIO $ readColourName name
setSourceColor col
C.setLineWidth wd
C.rectangle x0 y0 x1 y1
C.strokePreserve
outerBorder :: Config -> Double -> Double -> C.Render ()
outerBorder conf w h = do
let r = case border conf of
TopB -> (0, 0, w - 1, 0)
BottomB -> (0, h - 1, w - 1, h - 1)
FullB -> (0, 0, w - 1, h - 1)
TopBM m -> (0, fi m, w - 1, fi m)
BottomBM m -> (0, h - fi m, w - 1, h - fi m)
FullBM m -> (fi m, fi m, w - fi m - 1, h - fi m - 1)
NoBorder -> (-1, -1, -1, -1)
drawRect (borderColor conf) (fi (borderWidth conf)) r
where fi = fromIntegral
renderBorder :: Config -> Double -> Double -> Surface -> IO ()
renderBorder conf w h surf =
case border conf of
NoBorder -> return ()
_ -> C.renderWith surf (outerBorder conf w h)
layoutsWidth :: [(Segment, P.PangoLayout, Double, Double)] -> 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
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
renderBackground conf surface
(lend, as) <- foldM (renderLayout 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
when (borderWidth conf > 0) (renderBorder conf dw dh surface)
return as''
|
