summaryrefslogtreecommitdiffstats
path: root/tv/2configs/xserver/xmonad-tv/Util/Pager.hs
blob: b8168b5b05b52581ad2b50c01423185713ccfcf7 (plain)
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)