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
|
------------------------------------------------------------------------------
-- |
-- 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
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, P.FontBackground bg]
in P.markSpan attrs $ P.escapeMarkup txt
segmentMarkup _ _ = ""
type LayoutInfo = (Segment, P.PangoLayout, Double, Double)
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) = do
if off + lwidth > maxoff
then return (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')
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
renderBackground :: Config -> Surface -> IO ()
renderBackground conf surface = do
col <- case CNames.readColourName (bgColor conf) of
Just c -> return c
Nothing -> return $ SRGB.sRGB24read (bgColor conf)
C.renderWith surface (background conf col)
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
snd `fmap` foldM (renderLayout surface dw) (rstart, as') rlyts
|
