aboutsummaryrefslogtreecommitdiffstats
path: root/XMonad/Actions/GridSelect.hs
blob: 94432a01c7cbebf5aee2a5746d44523c42f3de65 (plain) (blame)
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
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.GridSelect
-- Copyright   :  Clemens Fruhwirth <clemens@endorphin.org>
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Clemens Fruhwirth <clemens@endorphin.org>
-- Stability   :  unstable
-- Portability :  unportable
--
-- GridSelect displays items(e.g. the opened windows) in a 2D grid and lets
-- the user select from it with the cursor/hjkl keys or the mouse.
--
-----------------------------------------------------------------------------

module XMonad.Actions.GridSelect (
    -- * Usage
    -- $usage

    -- ** Customizing
    -- *** Using a common GSConfig
    -- $commonGSConfig

    -- *** Custom keybindings
    -- $keybindings

    -- * Configuration
    GSConfig(..),
    defaultGSConfig,
    TwoDPosition,
    buildDefaultGSConfig,

    -- * Variations on 'gridselect'
    gridselect,
    gridselectWindow,
    withSelectedWindow,
    bringSelected,
    goToSelected,
    gridselectWorkspace,
    spawnSelected,
    runSelectedAction,

    -- * Colorizers
    HasColorizer(defaultColorizer),
    fromClassName,
    stringColorizer,
    colorRangeFromClassName,

    -- * Navigation Mode assembly
    TwoD,
    makeXEventhandler,
    shadowWithKeymap,

    -- * Built-in Navigation Mode
    defaultNavigation,
    substringSearch,
    navNSearch,

    -- * Navigation Components
    setPos,
    move,
    moveNext, movePrev,
    select,
    cancel,
    transformSearchString,

    -- * Screenshots
    -- $screenshots

    -- * Types
    TwoDState,
    ) where
import Data.Maybe
import Data.Bits
import Data.Char
import Control.Applicative
import Control.Monad.State
import Control.Arrow
import Data.List as L
import qualified Data.Map as M
import XMonad hiding (liftX)
import XMonad.Util.Font
import XMonad.Prompt (mkUnmanagedWindow)
import XMonad.StackSet as W
import XMonad.Layout.Decoration
import XMonad.Util.NamedWindows
import XMonad.Actions.WindowBringer (bringWindow)
import Text.Printf
import System.Random (mkStdGen, genRange, next)
import Data.Word (Word8)

-- $usage
--
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- >    import XMonad.Actions.GridSelect
--
-- Then add a keybinding, e.g.
--
-- >    , ((modm, xK_g), goToSelected defaultGSConfig)
--
-- This module also supports displaying arbitrary information in a grid and letting
-- the user select from it. E.g. to spawn an application from a given list, you
-- can use the following:
--
-- >   , ((modm, xK_s), spawnSelected defaultGSConfig ["xterm","gmplayer","gvim"])

-- $commonGSConfig
--
-- It is possible to bind a @gsconfig@ at top-level in your configuration. Like so:
--
-- > -- the top of your config
-- > {-# LANGUAGE NoMonomorphismRestriction #-}
-- > import XMonad
-- > ...
-- > gsconfig1 = defaultGSConfig { gs_cellheight = 30, gs_cellwidth = 100 }
--
-- An example where 'buildDefaultGSConfig' is used instead of 'defaultGSConfig'
-- in order to specify a custom colorizer is @gsconfig2@ (found in
-- "XMonad.Actions.GridSelect#Colorizers"):
--
-- > gsconfig2 colorizer = (buildDefaultGSConfig colorizer) { gs_cellheight = 30, gs_cellwidth = 100 }
--
-- > -- | A green monochrome colorizer based on window class
-- > greenColorizer = colorRangeFromClassName
-- >                      black            -- lowest inactive bg
-- >                      (0x70,0xFF,0x70) -- highest inactive bg
-- >                      black            -- active bg
-- >                      white            -- inactive fg
-- >                      white            -- active fg
-- >   where black = minBound
-- >         white = maxBound
--
-- Then you can bind to:
--
-- >     ,((modm, xK_g), goToSelected  $ gsconfig2 myWinColorizer)
-- >     ,((modm, xK_p), spawnSelected $ spawnSelected defaultColorizer)

-- $keybindings
--
-- You can build you own navigation mode and submodes by combining the
-- exported action ingredients and assembling them using 'makeXEventhandler' and 'shadowWithKeymap'.
--
-- > myNavigation :: TwoD a (Maybe a)
-- > myNavigation = makeXEventhandler $ shadowWithKeymap navKeyMap navDefaultHandler
-- >  where navKeyMap = M.fromList [
-- >           ((0,xK_Escape), cancel)
-- >          ,((0,xK_Return), select)
-- >          ,((0,xK_slash) , substringSearch myNavigation)
-- >          ,((0,xK_Left)  , move (-1,0)  >> myNavigation)
-- >          ,((0,xK_h)     , move (-1,0)  >> myNavigation)
-- >          ,((0,xK_Right) , move (1,0)   >> myNavigation)
-- >          ,((0,xK_l)     , move (1,0)   >> myNavigation)
-- >          ,((0,xK_Down)  , move (0,1)   >> myNavigation)
-- >          ,((0,xK_j)     , move (0,1)   >> myNavigation)
-- >          ,((0,xK_Up)    , move (0,-1)  >> myNavigation)
-- >          ,((0,xK_y)     , move (-1,-1) >> myNavigation)
-- >          ,((0,xK_i)     , move (1,-1)  >> myNavigation)
-- >          ,((0,xK_n)     , move (-1,1)  >> myNavigation)
-- >          ,((0,xK_m)     , move (1,-1)  >> myNavigation)
-- >          ,((0,xK_space) , setPos (0,0) >> myNavigation)
-- >          ]
-- >        -- The navigation handler ignores unknown key symbols
-- >        navDefaultHandler = const myNavigation
--
-- You can then define @gsconfig3@ which may be used in exactly the same manner as @gsconfig1@:
--
-- > gsconfig3 = defaultGSConfig
-- >    { gs_cellheight = 30
-- >    , gs_cellwidth = 100
-- >    , gs_navigate = myNavigation
-- >    }

-- $screenshots
--
-- Selecting a workspace:
--
-- <<http://haskell.org/wikiupload/a/a9/Xmonad-gridselect-workspace.png>>
--
-- Selecting a window by title:
--
-- <<http://haskell.org/wikiupload/3/35/Xmonad-gridselect-window-aavogt.png>>

data GSConfig a = GSConfig {
      gs_cellheight :: Integer,
      gs_cellwidth :: Integer,
      gs_cellpadding :: Integer,
      gs_colorizer :: a -> Bool -> X (String, String),
      gs_font :: String,
      gs_navigate :: TwoD a (Maybe a),
      gs_originFractX :: Double,
      gs_originFractY :: Double
}

-- | That is 'fromClassName' if you are selecting a 'Window', or
-- 'defaultColorizer' if you are selecting a 'String'. The catch-all instance
-- @HasColorizer a@ uses the 'focusedBorderColor' and 'normalBorderColor'
-- colors.
class HasColorizer a where
    defaultColorizer :: a -> Bool -> X (String, String)

instance HasColorizer Window where
    defaultColorizer = fromClassName

instance HasColorizer String where
    defaultColorizer = stringColorizer

instance HasColorizer a where
    defaultColorizer _ isFg =
        let getColor = if isFg then focusedBorderColor else normalBorderColor
        in asks $ flip (,) "black" . getColor . config

-- | A basic configuration for 'gridselect', with the colorizer chosen based on the type.
--
-- If you want to replace the 'gs_colorizer' field, use 'buildDefaultGSConfig'
-- instead, to avoid ambiguous type variables.
defaultGSConfig :: HasColorizer a => GSConfig a
defaultGSConfig = buildDefaultGSConfig defaultColorizer

type TwoDPosition = (Integer, Integer)

type TwoDElementMap a = [(TwoDPosition,(String,a))]

data TwoDState a = TwoDState { td_curpos :: TwoDPosition
                             , td_availSlots :: [TwoDPosition]
                             , td_elements :: [(String,a)]
                             , td_gsconfig :: GSConfig a
                             , td_font :: XMonadFont
                             , td_paneX :: Integer
                             , td_paneY :: Integer
                             , td_drawingWin :: Window
                             , td_searchString :: String
                             }

td_elementmap :: TwoDState a -> [(TwoDPosition,(String,a))]
td_elementmap s =
  let positions = td_availSlots s
      elements = L.filter (((td_searchString s) `isSubstringOf`) . fst) (td_elements s)
  in zipWith (,) positions elements
  where sub `isSubstringOf` string = or [ (upper sub) `isPrefixOf` t | t <- tails (upper string) ]
        upper = map toUpper

newtype TwoD a b = TwoD { unTwoD :: StateT (TwoDState a) X b }
    deriving (Monad,Functor,MonadState (TwoDState a))

instance Applicative (TwoD a) where
    (<*>) = ap
    pure = return

liftX ::  X a1 -> TwoD a a1
liftX = TwoD . lift

evalTwoD ::  TwoD a1 a -> TwoDState a1 -> X a
evalTwoD m s = flip evalStateT s $ unTwoD m

diamondLayer :: (Enum a, Num a, Eq a) => a -> [(a, a)]
diamondLayer 0 = [(0,0)]
diamondLayer n =
  -- tr = top right
  --  r = ur ++ 90 degree clock-wise rotation of ur
  let tr = [ (x,n-x) | x <- [0..n-1] ]
      r  = tr ++ (map (\(x,y) -> (y,-x)) tr)
  in r ++ (map (negate *** negate) r)

diamond :: (Enum a, Num a, Eq a) => [(a, a)]
diamond = concatMap diamondLayer [0..]

diamondRestrict :: Integer -> Integer -> Integer -> Integer -> [(Integer, Integer)]
diamondRestrict x y originX originY =
  L.filter (\(x',y') -> abs x' <= x && abs y' <= y) .
  map (\(x', y') -> (x' + fromInteger originX, y' + fromInteger originY)) .
  take 1000 $ diamond

findInElementMap :: (Eq a) => a -> [(a, b)] -> Maybe (a, b)
findInElementMap pos = find ((== pos) . fst)

drawWinBox :: Window -> XMonadFont -> (String, String) -> Integer -> Integer -> String -> Integer -> Integer -> Integer -> X ()
drawWinBox win font (fg,bg) ch cw text x y cp =
  withDisplay $ \dpy -> do
  gc <- liftIO $ createGC dpy win
  bordergc <- liftIO $ createGC dpy win
  liftIO $ do
    Just fgcolor <- initColor dpy fg
    Just bgcolor <- initColor dpy bg
    Just bordercolor <- initColor dpy borderColor
    setForeground dpy gc fgcolor
    setBackground dpy gc bgcolor
    setForeground dpy bordergc bordercolor
    fillRectangle dpy win gc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch)
    drawRectangle dpy win bordergc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch)
  stext <- shrinkWhile (shrinkIt shrinkText)
           (\n -> do size <- liftIO $ textWidthXMF dpy font n
                     return $ size > (fromInteger (cw-(2*cp))))
           text
  printStringXMF dpy win font gc bg fg (fromInteger (x+cp)) (fromInteger (y+(div ch 2))) stext
  liftIO $ freeGC dpy gc
  liftIO $ freeGC dpy bordergc

updateAllElements :: TwoD a ()
updateAllElements =
    do
      s <- get
      updateElements (td_elementmap s)

grayoutAllElements :: TwoD a ()
grayoutAllElements =
    do
      s <- get
      updateElementsWithColorizer grayOnly (td_elementmap s)
    where grayOnly _ _ = return ("#808080", "#808080")

updateElements :: TwoDElementMap a -> TwoD a ()
updateElements elementmap = do
      s <- get
      updateElementsWithColorizer (gs_colorizer (td_gsconfig s)) elementmap

updateElementsWithColorizer :: (a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a ()
updateElementsWithColorizer colorizer elementmap = do
    TwoDState { td_curpos = curpos,
                td_drawingWin = win,
                td_gsconfig = gsconfig,
                td_font = font,
                td_paneX = paneX,
                td_paneY = paneY} <- get
    let cellwidth = gs_cellwidth gsconfig
        cellheight = gs_cellheight gsconfig
        paneX' = div (paneX-cellwidth) 2
        paneY' = div (paneY-cellheight) 2
        updateElement (pos@(x,y),(text, element)) = liftX $ do
            colors <- colorizer element (pos == curpos)
            drawWinBox win font
                       colors
                       cellheight
                       cellwidth
                       text
                       (paneX'+x*cellwidth)
                       (paneY'+y*cellheight)
                       (gs_cellpadding gsconfig)
    mapM_ updateElement elementmap

stdHandle :: Event -> TwoD a (Maybe a) -> TwoD a (Maybe a)
stdHandle (ButtonEvent { ev_event_type = t, ev_x = x, ev_y = y }) contEventloop
    | t == buttonRelease = do
        s @  TwoDState { td_paneX = px, td_paneY = py,
                         td_gsconfig = (GSConfig ch cw _ _ _ _ _ _) } <- get
        let gridX = (fi x - (px - cw) `div` 2) `div` cw
            gridY = (fi y - (py - ch) `div` 2) `div` ch
        case lookup (gridX,gridY) (td_elementmap s) of
             Just (_,el) -> return (Just el)
             Nothing -> contEventloop
    | otherwise = contEventloop

stdHandle (ExposeEvent { }) contEventloop = updateAllElements >> contEventloop

stdHandle _ contEventloop = contEventloop

-- | Embeds a key handler into the X event handler that dispatches key
-- events to the key handler, while non-key event go to the standard
-- handler.
makeXEventhandler :: ((KeySym, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler keyhandler = fix $ \me -> join $ liftX $ withDisplay $ \d -> liftIO $ allocaXEvent $ \e -> do
                             maskEvent d (exposureMask .|. keyPressMask .|. buttonReleaseMask) e
                             ev <- getEvent e
                             if ev_event_type ev == keyPress
                               then do
                                  (ks,s) <- lookupString $ asKeyEvent e
                                  return $ do
                                      mask <- liftX $ cleanMask (ev_state ev)
                                      keyhandler (fromMaybe xK_VoidSymbol ks, s, mask)
                               else
                                  return $ stdHandle ev me

-- | When the map contains (KeySym,KeyMask) tuple for the given event,
-- the associated action in the map associated shadows the default key
-- handler
shadowWithKeymap :: M.Map (KeyMask, KeySym) a -> ((KeySym, String, KeyMask) -> a) -> (KeySym, String, KeyMask) -> a
shadowWithKeymap keymap dflt keyEvent@(ks,_,m') = fromMaybe (dflt keyEvent) (M.lookup (m',ks) keymap)

-- Helper functions to use for key handler functions

-- | Closes gridselect returning the element under the cursor
select :: TwoD a (Maybe a)
select = do
  s <- get
  return $ fmap (snd . snd) $ findInElementMap (td_curpos s) (td_elementmap s)

-- | Closes gridselect returning no element.
cancel :: TwoD a (Maybe a)
cancel = return Nothing

-- | Sets the absolute position of the cursor.
setPos :: (Integer, Integer) -> TwoD a ()
setPos newPos = do
  s <- get
  let elmap = td_elementmap s
      newSelectedEl = findInElementMap newPos (td_elementmap s)
      oldPos = td_curpos s
  when (isJust newSelectedEl && newPos /= oldPos) $ do
    put s { td_curpos = newPos }
    updateElements (catMaybes [(findInElementMap oldPos elmap), newSelectedEl])

-- | Moves the cursor by the offsets specified
move :: (Integer, Integer) -> TwoD a ()
move (dx,dy) = do
  s <- get
  let (x,y) = td_curpos s
      newPos = (x+dx,y+dy)
  setPos newPos

moveNext :: TwoD a ()
moveNext = do
  position <- gets td_curpos
  elems <- gets td_elementmap
  let n = length elems
      m = case findIndex (\p -> fst p == position) elems of
               Nothing -> Nothing
               Just k | k == n-1 -> Just 0
                      | otherwise -> Just (k+1)
  whenJust m $ \i ->
      setPos (fst $ elems !! i)

movePrev :: TwoD a ()
movePrev = do
  position <- gets td_curpos
  elems <- gets td_elementmap
  let n = length elems
      m = case findIndex (\p -> fst p == position) elems of
               Nothing -> Nothing
               Just 0  -> Just (n-1)
               Just k  -> Just (k-1)
  whenJust m $ \i ->
      setPos (fst $ elems !! i)

-- | Apply a transformation function the current search string
transformSearchString :: (String -> String) -> TwoD a ()
transformSearchString f = do
          s <- get
          let oldSearchString = td_searchString s
              newSearchString = f oldSearchString
          when (newSearchString /= oldSearchString) $ do
            -- FIXME: grayoutAllElements + updateAllElements paint some fields twice causing flickering
            --        we would need a much smarter update strategy to fix that
            when (length newSearchString > length oldSearchString) grayoutAllElements
            -- FIXME curpos might end up outside new bounds
            put s { td_searchString = newSearchString }
            updateAllElements

-- | By default gridselect used the defaultNavigation action, which
-- binds left,right,up,down and vi-style h,l,j,k navigation. Return
-- quits gridselect, returning the selected element, while Escape
-- cancels the selection. Slash enters the substring search mode. In
-- substring search mode, every string-associated keystroke is
-- added to a search string, which narrows down the object
-- selection. Substring search mode comes back to regular navigation
-- via Return, while Escape cancels the search. If you want that
-- navigation style, add 'defaultNavigation' as 'gs_navigate' to your
-- 'GSConfig' object. This is done by 'buildDefaultGSConfig' automatically.
defaultNavigation :: TwoD a (Maybe a)
defaultNavigation = makeXEventhandler $ shadowWithKeymap navKeyMap navDefaultHandler
  where navKeyMap = M.fromList [
           ((0,xK_Escape)     , cancel)
          ,((0,xK_Return)     , select)
          ,((0,xK_slash)      , substringSearch defaultNavigation)
          ,((0,xK_Left)       , move (-1,0) >> defaultNavigation)
          ,((0,xK_h)          , move (-1,0) >> defaultNavigation)
          ,((0,xK_Right)      , move (1,0) >> defaultNavigation)
          ,((0,xK_l)          , move (1,0) >> defaultNavigation)
          ,((0,xK_Down)       , move (0,1) >> defaultNavigation)
          ,((0,xK_j)          , move (0,1) >> defaultNavigation)
          ,((0,xK_Up)         , move (0,-1) >> defaultNavigation)
          ,((0,xK_k)          , move (0,-1) >> defaultNavigation)
          ,((0,xK_Tab)        , moveNext >> defaultNavigation)
          ,((0,xK_n)          , moveNext >> defaultNavigation)
          ,((shiftMask,xK_Tab), movePrev >> defaultNavigation)
          ,((0,xK_p)          , movePrev >> defaultNavigation)
          ]
        -- The navigation handler ignores unknown key symbols, therefore we const
        navDefaultHandler = const defaultNavigation

-- | This navigation style combines navigation and search into one mode at the cost of losing vi style
-- navigation. With this style, there is no substring search submode,
-- but every typed character is added to the substring search.
navNSearch :: TwoD a (Maybe a)
navNSearch = makeXEventhandler $ shadowWithKeymap navNSearchKeyMap navNSearchDefaultHandler
  where navNSearchKeyMap = M.fromList [
           ((0,xK_Escape)     , cancel)
          ,((0,xK_Return)     , select)
          ,((0,xK_Left)       , move (-1,0) >> navNSearch)
          ,((0,xK_Right)      , move (1,0) >> navNSearch)
          ,((0,xK_Down)       , move (0,1) >> navNSearch)
          ,((0,xK_Up)         , move (0,-1) >> navNSearch)
          ,((0,xK_Tab)        , moveNext >> navNSearch)
          ,((shiftMask,xK_Tab), movePrev >> navNSearch)
          ,((0,xK_BackSpace), transformSearchString (\s -> if (s == "") then "" else init s) >> navNSearch)
          ]
        -- The navigation handler ignores unknown key symbols, therefore we const
        navNSearchDefaultHandler (_,s,_) = do
          transformSearchString (++ s)
          navNSearch

-- | Navigation submode used for substring search. It returns to the
-- first argument navigation style when the user hits Return.
substringSearch :: TwoD a (Maybe a) -> TwoD a (Maybe a)
substringSearch returnNavigation = fix $ \me ->
  let searchKeyMap = M.fromList [
           ((0,xK_Escape)   , transformSearchString (const "") >> returnNavigation)
          ,((0,xK_Return)   , returnNavigation)
          ,((0,xK_BackSpace), transformSearchString (\s -> if (s == "") then "" else init s) >> me)
          ]
      searchDefaultHandler (_,s,_) = do
          transformSearchString (++ s)
          me
  in makeXEventhandler $ shadowWithKeymap searchKeyMap searchDefaultHandler


-- FIXME probably move that into Utils?
-- Conversion scheme as in http://en.wikipedia.org/wiki/HSV_color_space
hsv2rgb :: Fractional a => (Integer,a,a) -> (a,a,a)
hsv2rgb (h,s,v) =
    let hi = (div h 60) `mod` 6 :: Integer
        f = (((fromInteger h)/60) - (fromInteger hi)) :: Fractional a => a
        q = v * (1-f)
        p = v * (1-s)
        t = v * (1-(1-f)*s)
    in case hi of
         0 -> (v,t,p)
         1 -> (q,v,p)
         2 -> (p,v,t)
         3 -> (p,q,v)
         4 -> (t,p,v)
         5 -> (v,p,q)
         _ -> error "The world is ending. x mod a >= a."

-- | Default colorizer for Strings
stringColorizer :: String -> Bool -> X (String, String)
stringColorizer s active =
    let seed x = toInteger (sum $ map ((*x).fromEnum) s) :: Integer
        (r,g,b) = hsv2rgb ((seed 83) `mod` 360,
                           (fromInteger ((seed 191) `mod` 1000))/2500+0.4,
                           (fromInteger ((seed 121) `mod` 1000))/2500+0.4)
    in if active
         then return ("#faff69", "black")
         else return ("#" ++ concat (map (twodigitHex.(round :: Double -> Word8).(*256)) [r, g, b] ), "white")

-- | Colorize a window depending on it's className.
fromClassName :: Window -> Bool -> X (String, String)
fromClassName w active = runQuery className w >>= flip defaultColorizer active

twodigitHex :: Word8 -> String
twodigitHex a = printf "%02x" a

-- | A colorizer that picks a color inside a range,
-- and depending on the window's class.
colorRangeFromClassName :: (Word8, Word8, Word8) -- ^ Beginning of the color range
                        -> (Word8, Word8, Word8) -- ^ End of the color range
                        -> (Word8, Word8, Word8) -- ^ Background of the active window
                        -> (Word8, Word8, Word8) -- ^ Inactive text color
                        -> (Word8, Word8, Word8) -- ^ Active text color
                        -> Window -> Bool -> X (String, String)
colorRangeFromClassName startC endC activeC inactiveT activeT w active =
    do classname <- runQuery className w
       if active
         then return (rgbToHex activeC, rgbToHex activeT)
         else return (rgbToHex $ mix startC endC
                  $ stringToRatio classname, rgbToHex inactiveT)
    where rgbToHex :: (Word8, Word8, Word8) -> String
          rgbToHex (r, g, b) = '#':twodigitHex r
                               ++twodigitHex g++twodigitHex b

-- | Creates a mix of two colors according to a ratio
-- (1 -> first color, 0 -> second color).
mix :: (Word8, Word8, Word8) -> (Word8, Word8, Word8)
        -> Double -> (Word8, Word8, Word8)
mix (r1, g1, b1) (r2, g2, b2) r = (mix' r1 r2, mix' g1 g2, mix' b1 b2)
    where  mix' a b = truncate $ (fi a * r) + (fi b * (1 - r))

-- | Generates a Double from a string, trying to
-- achieve a random distribution.
-- We create a random seed from the sum of all characters
-- in the string, and use it to generate a ratio between 0 and 1
stringToRatio :: String -> Double
stringToRatio "" = 0
stringToRatio s = let gen = mkStdGen $ sum $ map fromEnum s
                      range = (\(a, b) -> b - a) $ genRange gen
                      randomInt = foldr1 combine $ replicate 20 next
                      combine f1 f2 g = let (_, g') = f1 g in f2 g'
                  in fi (fst $ randomInt gen) / fi range

-- | Brings up a 2D grid of elements in the center of the screen, and one can
-- select an element with cursors keys. The selected element is returned.
gridselect :: GSConfig a -> [(String,a)] -> X (Maybe a)
gridselect _ [] = return Nothing
gridselect gsconfig elements =
 withDisplay $ \dpy -> do
    rootw <- asks theRoot
    s <- gets $ screenRect . W.screenDetail . W.current . windowset
    win <- liftIO $ mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw
                    (rect_x s) (rect_y s) (rect_width s) (rect_height s)
    liftIO $ mapWindow dpy win
    liftIO $ selectInput dpy win (exposureMask .|. keyPressMask .|. buttonReleaseMask)
    status <- io $ grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime
    io $ grabButton dpy button1 anyModifier win True buttonReleaseMask grabModeAsync grabModeAsync none none
    font <- initXMF (gs_font gsconfig)
    let screenWidth = toInteger $ rect_width s;
        screenHeight = toInteger $ rect_height s;
    selectedElement <- if (status == grabSuccess) then do
                            let restriction ss cs = (fromInteger ss/fromInteger (cs gsconfig)-1)/2 :: Double
                                restrictX = floor $ restriction screenWidth gs_cellwidth
                                restrictY = floor $ restriction screenHeight gs_cellheight
                                originPosX = floor $ ((gs_originFractX gsconfig) - (1/2)) * 2 * fromIntegral restrictX
                                originPosY = floor $ ((gs_originFractY gsconfig) - (1/2)) * 2 * fromIntegral restrictY
                                coords = diamondRestrict restrictX restrictY originPosX originPosY

                            evalTwoD (updateAllElements >> (gs_navigate gsconfig)) TwoDState { td_curpos = (head coords),
                                                                                  td_availSlots = coords,
                                                                                  td_elements = elements,
                                                                                  td_gsconfig = gsconfig,
                                                                                  td_font = font,
                                                                                  td_paneX = screenWidth,
                                                                                  td_paneY = screenHeight,
                                                                                  td_drawingWin = win,
                                                                                  td_searchString = "" }
                      else
                          return Nothing
    liftIO $ do
      unmapWindow dpy win
      destroyWindow dpy win
      sync dpy False
    releaseXMF font
    return selectedElement

-- | Like `gridSelect' but with the current windows and their titles as elements
gridselectWindow :: GSConfig Window -> X (Maybe Window)
gridselectWindow gsconf = windowMap >>= gridselect gsconf

-- | Brings up a 2D grid of windows in the center of the screen, and one can
-- select a window with cursors keys. The selected window is then passed to
-- a callback function.
withSelectedWindow :: (Window -> X ()) -> GSConfig Window -> X ()
withSelectedWindow callback conf = do
    mbWindow <- gridselectWindow conf
    case mbWindow of
        Just w -> callback w
        Nothing -> return ()

windowMap :: X [(String,Window)]
windowMap = do
    ws <- gets windowset
    wins <- mapM keyValuePair (W.allWindows ws)
    return wins
 where keyValuePair w = flip (,) w `fmap` decorateName' w

decorateName' :: Window -> X String
decorateName' w = do
  fmap show $ getName w

-- | Builds a default gs config from a colorizer function.
buildDefaultGSConfig :: (a -> Bool -> X (String,String)) -> GSConfig a
buildDefaultGSConfig col = GSConfig 50 130 10 col "xft:Sans-8" defaultNavigation (1/2) (1/2)

borderColor :: String
borderColor = "white"

-- | Brings selected window to the current workspace.
bringSelected :: GSConfig Window -> X ()
bringSelected = withSelectedWindow $ \w -> do
    windows (bringWindow w)
    XMonad.focus w
    windows W.shiftMaster

-- | Switches to selected window's workspace and focuses that window.
goToSelected :: GSConfig Window -> X ()
goToSelected = withSelectedWindow $ windows . W.focusWindow

-- | Select an application to spawn from a given list
spawnSelected :: GSConfig String -> [String] -> X ()
spawnSelected conf lst = gridselect conf (zip lst lst) >>= flip whenJust spawn

-- | Select an action and run it in the X monad
runSelectedAction :: GSConfig (X ()) -> [(String, X ())] -> X ()
runSelectedAction conf actions = do
    selectedActionM <- gridselect conf actions
    case selectedActionM of
        Just selectedAction -> selectedAction
        Nothing -> return ()

-- | Select a workspace and view it using the given function
-- (normally 'W.view' or 'W.greedyView')
--
-- Another option is to shift the current window to the selected workspace:
--
-- > gridselectWorkspace (\ws -> W.greedyView ws . W.shift ws)
gridselectWorkspace :: GSConfig WorkspaceId ->
                          (WorkspaceId -> WindowSet -> WindowSet) -> X ()
gridselectWorkspace conf viewFunc = withWindowSet $ \ws -> do
    let wss = map W.tag $ W.hidden ws ++ map W.workspace (W.current ws : W.visible ws)
    gridselect conf (zip wss wss) >>= flip whenJust (windows . viewFunc)