summaryrefslogtreecommitdiffstats
path: root/XMonad/Stockholm/Rhombus.hs
blob: b4d68618763c3315f407cec0d3fa49f33e207f88 (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
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
module XMonad.Stockholm.Rhombus
    ( MatchMethod(..)
    , rhombus
    , RhombusConfig(..)
    , RhombusState(..)
    ) where

import Control.Monad (zipWithM_)
import Data.Char
import Data.List
import Data.Ord
import Data.Map (fromList)
import Data.Maybe (fromJust)
import XMonad hiding (keys)
import XMonad.StackSet hiding (filter, tag)
import XMonad.Util.Font
import XMonad.Util.XUtils

import XMonad.Stockholm.Submap
import XMonad.Stockholm.XUtils
import XMonad.Stockholm.Font


data MatchMethod = MatchInfix | MatchPrefix

data RhombusConfig = RhombusConfig
    { rc_font           :: String
    , rc_cellwidth      :: Dimension
    , rc_margin         :: Dimension
    , rc_matchmethod    :: MatchMethod
    , rc_wrap           :: Bool
    , rc_colors         :: Bool -> Bool -> Bool -> (String, String, String)
    , rc_paint          :: RhombusConfig -> Display -> Pixmap -> GC -> String -> Rectangle -> Bool -> Bool -> Bool -> X ()
    , rc_missAction     :: X ()
    }


-- TODO currently xft is broken
instance Default RhombusConfig where
    def = RhombusConfig
        { rc_font = "xft:Sans-8"
        , rc_cellwidth = 100
        , rc_margin = 0
        , rc_matchmethod = MatchInfix
        , rc_wrap = True
        , rc_colors = stupidColors
        , rc_paint = noPaint
        , rc_missAction = return ()
        }
      where
        stupidColors _ _ _ = ("red", "magenta", "yellow")
        noPaint _ _ _ _ _ _ _ _ _ = return ()

data RhombusState = RhombusState
    { rs_window     :: Window
    , rs_search     :: String
    , rs_font       :: XMonadFont
    , rs_focus      :: (Position, Position)
    , rs_strings    :: [String]
    }


reachableCoords :: RhombusState -> [(Position, Position)]
reachableCoords RhombusState{rs_strings=xs} = take (length xs) wave


matchingReachableCoords :: RhombusConfig -> RhombusState -> [(Position, Position)]
matchingReachableCoords rc rs =
    snd $ unzip
        $ filter (isXOf (rc_matchmethod rc) (rs_search rs) . fst)
        $ zip (rs_strings rs) (reachableCoords rs)


match :: MatchMethod -> String -> [String] -> Maybe String
match m s ws = do
    let cands = filter (isXOf m s) ws
    if length cands == 1
        then Just $ head cands
        else Nothing

rhombus :: RhombusConfig -> (String -> X ()) -> [String] -> X ()
rhombus rc viewFunc as = withGrabbedKeyboard $ do
    rs <- newRhombus rc as
    --redraw rc rs
    showWindow (rs_window rs)
    rhombusMode viewFunc rc rs


rhombusMode :: (String -> X ()) -> RhombusConfig -> RhombusState -> X ()
rhombusMode viewFunc rc rs =
    case match (rc_matchmethod rc) (rs_search rs) (init $ rs_strings rs) of
        Nothing -> redraw rc rs >> submapString defAction keys
        Just i -> removeRhombus rs >> viewFunc i
    where
    defAction (ch:[]) | isPrint ch =
        incSearchPushChar ch rs >>= rhombusMode viewFunc rc

    defAction _ =
        rc_missAction rc >> rhombusMode viewFunc rc rs

    keys = fromList $
        [ ((0   , xK_BackSpace  ), incSearchPopChar rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Escape     ), removeRhombus rs)
        , ((0   , xK_Menu       ), removeRhombus rs)
        , ((0   , xK_Left       ), goto rc (-1, 0) rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Right      ), goto rc ( 1, 0) rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Up         ), goto rc ( 0,-1) rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Down       ), goto rc ( 0, 1) rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Tab        ), gotoNextMatch rc rs >>= rhombusMode viewFunc rc)
        , ((_S  , xK_Tab        ), gotoPrevMatch rc rs >>= rhombusMode viewFunc rc)
        , ((0   , xK_Return     ), removeRhombus rs >> return (selectFocused rs) >>= viewFunc)
        ]

    _S = shiftMask


goto :: RhombusConfig -> (Position, Position) -> RhombusState -> X RhombusState
goto rc xy rs =
    maybe (rc_missAction rc >> return rs) return $ op xy rs
  where
    op = if rc_wrap rc then wrapFocus else moveFocus


moveFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState
moveFocus (dx, dy) rs@RhombusState{rs_focus=(x,y)} = do
    let foc' = (x + dx, y + dy)
    if elem foc' (reachableCoords rs)
        then Just rs { rs_focus = foc' }
        else Nothing


wrapFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState

wrapFocus (0, dy) rs@RhombusState{rs_focus=foc} = do
    let column = sortBy (comparing snd) $ filter ((==) (fst foc) . fst) (reachableCoords rs)
    i <- elemIndex foc column
    return rs { rs_focus = column `modIndex` (i + fromIntegral dy) }

wrapFocus (dx, 0) rs@RhombusState{rs_focus=foc} = do
    let column = sortBy (comparing fst) $ filter ((==) (snd foc) . snd) (reachableCoords rs)
    i <- elemIndex foc column
    return rs { rs_focus = column `modIndex` (i + fromIntegral dx) }

wrapFocus _ _ = Nothing


gotoPrevMatch :: RhombusConfig -> RhombusState -> X RhombusState
gotoPrevMatch rc rs@RhombusState{rs_focus=foc} = do
    case reverse (matchingReachableCoords rc rs) of
        [] -> rc_missAction rc >> return rs
        xs -> return rs
            { rs_focus = maybe (head xs)
                               (modIndex xs . (+1))
                               (foc `elemIndex` xs)
            }


gotoNextMatch :: RhombusConfig -> RhombusState -> X RhombusState
gotoNextMatch rc rs@RhombusState{rs_focus=foc} = do
    case matchingReachableCoords rc rs of
        [] -> rc_missAction rc >> return rs
        xs -> return rs
            { rs_focus = maybe (head xs)
                               (modIndex xs . (+1))
                               (foc `elemIndex` xs)
            }


selectFocused :: RhombusState -> String
selectFocused rs =
    -- TODO the rhombus must never "focus" something inexistent
    fromJust $ lookup (rs_focus rs) $ zip wave (rs_strings rs)


incSearchPushChar :: Char -> RhombusState -> X RhombusState
incSearchPushChar c rs = return rs { rs_search = rs_search rs ++ [c] }


incSearchPopChar :: RhombusState -> X RhombusState

-- only rubout if we have at least one char
incSearchPopChar rs@RhombusState{rs_search=xs@(_:_)} =
    return rs { rs_search = init xs }

incSearchPopChar rs = return rs


redraw :: RhombusConfig -> RhombusState -> X ()
redraw rc rs = do
    ss <- gets windowset

    let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss

    -- TODO this let is duplicated in newRhombus
    let scale x = x * cell_w `div` s_width -- TODO use bw
        cell_w  = rc_cellwidth rc
        cell_h  = scale s_height

        -- txy is the top-left corner of the first (center) cell
        -- XXX div and (-) are not distributive
        --     we could round $ (s_* - cell_*) / 2, though...
        tx = fi $ s_width  `div` 2 - cell_w `div` 2
        ty = fi $ s_height `div` 2 - cell_h `div` 2

        margin = rc_margin rc

        -- dxy are the outer cell dimensions (i.e. including the border)
        dx = fi $ cell_w + 2 + margin
        dy = fi $ cell_h + 2 + margin

        paint = rc_paint rc
        xmf   = rs_font rs
        tags  = rs_strings rs
        --currentTag = last tags

    withDisplay $ \ d -> do
        -- XXX we cannot use withPixmapAndGC because rc_paint is an X monad
        p <- io $ createPixmap d (rs_window rs) s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d)
        g <- io $ createGC d p

        -- TODO fixme
        color_black <- stringToPixel d "black"

        forZipWithM_ tags (reachableCoords rs) $ \tag oxy@(ox, oy) -> do

            let isFocused = oxy == rs_focus rs
                isMatched = isXOf (rc_matchmethod rc) (rs_search rs) tag
                isCurrent = tag == last tags
                (_b_color, _bg_color, _fg_color) = rc_colors rc isFocused isMatched isCurrent
                --cell_x = (ox * dx) + x - fi (cell_w `div` 2)
                --cell_y = (oy * dy) + y - fi (cell_h `div` 2)
                cell_x = (ox * dx) + tx + 1
                cell_y = (oy * dy) + ty + 1

            b_color <- stringToPixel d _b_color
            bg_color <- stringToPixel d _bg_color
            fg_color <- stringToPixel d _fg_color

            -- draw background
            io $ setForeground d g bg_color
            io $ fillRectangle d p g cell_x cell_y cell_w cell_h

            -- draw border
            io $ setForeground d g b_color
            io $ drawLines d p g
                    [ Point (cell_x - 1) (cell_y - 1)
                    , Point (fi cell_w + 1) 0
                    , Point 0 (fi cell_h + 1)
                    , Point (-(fi cell_w + 1)) 0
                    , Point 0 (-(fi cell_h + 1))
                    ]
                    coordModePrevious

            -- custom draw
            paint rc d p g tag (Rectangle cell_x cell_y cell_w cell_h) isFocused isMatched isCurrent

            -- paint text
            -- TODO custom paint text?
            -- TODO withCopyArea
            io $ withPixmapAndGC d p s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d) $ \ f_pm f_gc -> do
                withPixmapAndGC d f_pm s_width s_height 1 $ \ clip_mask clip_gc -> do
                    setForeground d clip_gc 0
                    setBackground d clip_gc 0
                    fillRectangle d clip_mask clip_gc 0 0 s_width s_height
                    setForeground d clip_gc 1

                    let r = Rectangle cell_x cell_y cell_w cell_h

                    printStringCentered d clip_mask xmf clip_gc r tag

                    setForeground d f_gc fg_color
                    setBackground d f_gc color_black -- TODO

                    printStringCentered d f_pm xmf f_gc r tag

                    setClipMask d f_gc clip_mask

                    copyArea d f_pm p f_gc 0 0 s_width s_height 0 0

        io $ copyArea d p (rs_window rs) g 0 0 s_width s_height 0 0
        io $ freePixmap d p
        io $ freeGC d g


newRhombus :: RhombusConfig -> [String] -> X RhombusState
newRhombus rc tags = do
    ss <- gets windowset

    let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss
        (_, def_win_bg, _) = rc_colors rc False True False

    -- TODO this let is duplicated in redraw
    let scale x = x * cell_w `div` s_width -- TODO use bw
        cell_w  = rc_cellwidth rc
        cell_h  = scale s_height

        -- TODO don't delete this let but use it instead of s_{width,height}
        -- (xcoords, ycoords) = unzip $ take (length tags) wave -- this is reachableCoords
        -- win_width  = (maximum xcoords - minimum xcoords) * dx
        -- win_height = (maximum ycoords - minimum ycoords) * dy

        -- txy is the top-left corner of the first (center) cell
        -- XXX div and (-) are not distributive
        --     we could round $ (s_* - cell_*) / 2, though...
        tx = fi $ s_width  `div` 2 - cell_w `div` 2
        ty = fi $ s_height `div` 2 - cell_h `div` 2

        margin = rc_margin rc

        -- dxy are the outer cell dimensions (i.e. including the border)
        dx = fi $ cell_w + 2 + margin
        dy = fi $ cell_h + 2 + margin

    fn <- initXMF (rc_font rc)
    win <- createNewWindow (Rectangle 0 0 s_width s_height) Nothing def_win_bg True

    withDisplay $ \ d ->
        io $ shapeWindow d win $ \ p g ->
            forZipWithM_ tags wave $ \ _ (ox, oy) ->
                fillRectangle d p g (tx + ox * dx) (ty + oy * dy) (fi cell_w + 2) (fi cell_h + 2)

    return $ RhombusState win "" fn (0,0) tags


removeRhombus :: RhombusState -> X ()
removeRhombus (RhombusState w _ fn _ _) = do
    deleteWindow w
    releaseXMF fn

wave :: [(Position, Position)]
wave = zip (0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])) (concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..])
    --where
    --    wave1 = 0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])
    --    wave2 = concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..]



isXOf :: MatchMethod -> String -> String -> Bool
isXOf MatchInfix  = isInfixOf
isXOf MatchPrefix = isPrefixOf


modIndex :: Integral i => [a] -> i -> a
modIndex xs i = xs `genericIndex` (i `mod` genericLength xs)


forZipWithM_ :: Monad m => [a] -> [b] -> (a -> b -> m c) -> m ()
forZipWithM_ a b f = zipWithM_ f a b


withGrabbedKeyboard :: X () -> X ()
withGrabbedKeyboard f = do
    XConf { theRoot = root, display = d } <- ask
    catchX (io (grabKeyboard d root False grabModeAsync grabModeAsync currentTime) >> f)
           (return ())
    io $ ungrabKeyboard d currentTime