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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
module Util.Pager
( defaultPagerConfig
, defaultWindowColors
, defaultWorkspaceColors
, MatchMethod(..)
, pager
, PagerConfig(..)
) where
import Data.List ( find )
import Data.Maybe ( catMaybes )
import Graphics.X11
import Util.Rhombus
import XMonad
import qualified XMonad.StackSet as W
import XMonad.Hooks.UrgencyHook
import XMonad.Util.Font ( fi, stringToPixel )
data PagerConfig = PagerConfig
{ pc_font :: String
, pc_cellwidth :: Dimension
, pc_margin :: Dimension
, pc_matchmethod :: MatchMethod
, pc_wrap :: Bool
, pc_workspaceColors :: Bool -> Bool -> Bool -> (String, String, String)
, pc_windowColors :: Bool -> Bool -> Bool -> Bool -> Bool -> (String, String)
}
defaultPagerConfig :: PagerConfig
defaultPagerConfig = PagerConfig "xft:Sans-8" 100 0 MatchInfix True defaultWorkspaceColors defaultWindowColors
pager :: PagerConfig -> (String -> X ()) -> [String] -> X ()
pager pc = rhombus defaultRhombusConfig
{ rc_font = pc_font pc
, rc_cellwidth = pc_cellwidth pc
, rc_margin = pc_margin pc
, rc_matchmethod = pc_matchmethod pc
, rc_wrap = pc_wrap pc
, rc_colors = pc_workspaceColors pc
, rc_paint = pagerPaint pc
}
defaultWorkspaceColors :: Bool -- workspace has focus
-> Bool -- workspace name matches incremental search
-> Bool -- workspace is the current one
-> (String, String, String) -- workspace border, background color, and foreground color
defaultWorkspaceColors False False False = ("#101010","#050505","#202020")
defaultWorkspaceColors False False True = ("#101010","#050505","#202020")
defaultWorkspaceColors False True False = ("#404040","#202020","#b0b0b0")
defaultWorkspaceColors False True True = ("#101010","#050505","#505050")
defaultWorkspaceColors True _ False = ("#808020","#404010","#f0f0b0")
defaultWorkspaceColors True _ True = ("#404010","#202005","#909050")
defaultWindowColors :: Bool -- window's workspace has focus
-> Bool -- window's workspace name matches incremental search
-> Bool -- window's workspace the current one
-> Bool -- window is urgent
-> Bool -- window has focus
-> (String, String) -- window border and background color
defaultWindowColors wsf m c u True = ("#802020", snd $ defaultWindowColors wsf m c u False)
defaultWindowColors False False False False _ = ("#111111","#060606")
defaultWindowColors False False False True _ = ("#802020","#401010")
defaultWindowColors False False True False _ = ("#101010","#050505")
defaultWindowColors False False True True _ = ("#401010","#200505")
defaultWindowColors False True False False _ = ("#202080","#101040")
defaultWindowColors False True False True _ = ("#802080","#401040")
defaultWindowColors False True True False _ = ("#101040","#100520")
defaultWindowColors False True True True _ = ("#401040","#200520")
defaultWindowColors True False False False _ = ("#208020","#104010")
defaultWindowColors True False False True _ = ("#808020","#404010")
defaultWindowColors True False True False _ = ("#104010","#052005")
defaultWindowColors True False True True _ = ("#404010","#202005")
defaultWindowColors True True False False _ = ("#208080","#104040")
defaultWindowColors True True False True _ = ("#808080","#404040")
defaultWindowColors True True True False _ = ("#104040","#102020")
defaultWindowColors True True True True _ = ("#404040","#202020")
pagerPaint ::
PagerConfig
-> RhombusConfig
-> Display
-> Drawable
-> GC
-> WorkspaceId
-> Rectangle
-> Bool
-> Bool
-> Bool
-> X ()
pagerPaint pc rc d p gc t r focus match current = do
ss <- gets windowset
let x = rect_x r
y = rect_y r
urgents <- readUrgents
let foci = map W.focus $ catMaybes $ map W.stack $ W.workspaces ss
let color = pc_windowColors pc focus match current -- :: Bool -> (String, String)
(_, _, _fg_color) = pc_workspaceColors pc focus match current
fg_color <- stringToPixel d _fg_color
let r = screenRect $ W.screenDetail $ W.current ss
let a = fi (rect_width r) / fi (rect_height r)
let scale = fi (rc_cellwidth rc) / fi (rect_width r)
-- TODO whenNothing print error
whenJust (findWorkspace t ss) $ \ ws -> do
whenJust (W.stack ws) $ \ s ->
withDisplay $ \ d -> io $ do
let color' w = color (w `elem` urgents) (w `elem` foci)
-- TODO painting of floating windows is broken
mapM_ (drawMiniWindow d p gc x y color' scale) (W.down s)
drawMiniWindow d p gc x y color' scale (W.focus s)
mapM_ (drawMiniWindow d p gc x y color' scale) (W.up s)
drawMiniWindow
:: RealFrac a
=> Display
-> Drawable
-> GC
-> Position
-> Position
-> (Window -> (String, String))
-> a
-> Window
-> IO ()
drawMiniWindow d p gc ox oy color s win = do
let scale x = round $ fi x * s
wa <- getWindowAttributes d win
let x = ox + (scale $ wa_x wa)
y = oy + (scale $ wa_y wa)
w = (scale $ wa_width wa)
h = (scale $ wa_height wa)
let (fg, bg) = color win
fg' <- stringToPixel d fg
bg' <- stringToPixel d bg
setForeground d gc bg'
fillRectangle d p gc (x + 1) (y + 1) (w - 2) (h - 2)
setForeground d gc fg'
drawLines d p gc
[ Point x y
, Point (fi w - 1) 0
, Point 0 (fi h - 2)
, Point (- fi w + 1) 0
, Point 0 (- fi h + 2)
]
coordModePrevious
-- TODO externalize findWorkspace
findWorkspace :: (Eq i) => i -> W.StackSet i l a sid sd -> Maybe (W.Workspace i l a)
findWorkspace t ss = find ((==)t . W.tag) (W.workspaces ss)
|
