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
|
{-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonadContrib.WorkspaceDir
-- Copyright : (c) 2007 David Roundy <droundy@darcs.net>
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : David Roundy <droundy@darcs.net>
-- Stability : unstable
-- Portability : unportable
--
-- WindowNavigation is an extension to allow easy navigation of a workspace.
--
-----------------------------------------------------------------------------
module XMonadContrib.WindowNavigation (
-- * Usage
-- $usage
windowNavigation,
Navigate(..), Direction(..)
) where
import Graphics.X11.Xlib ( Rectangle(..), Window, setWindowBorder )
import Control.Monad.Reader ( ask, asks )
import Data.List ( nub, sortBy, (\\) )
import XMonad
import qualified StackSet as W
import Operations ( focus, initColor, LayoutMessages(..) )
import XMonadContrib.LayoutModifier
import XMonadContrib.Invisible
-- $usage
-- You can use this module with the following in your Config.hs file:
--
-- > import XMonadContrib.WindowNavigation
-- >
-- > defaultLayout = SomeLayout $ windowNavigation $ LayoutSelection ...
--
-- In keybindings:
--
-- > , ((modMask, xK_Right), sendMessage $ Go R)
-- > , ((modMask, xK_Left), sendMessage $ Go L)
-- > , ((modMask, xK_Up), sendMessage $ Go U)
-- > , ((modMask, xK_Down), sendMessage $ Go D)
-- %import XMonadContrib.WindowNavigation
-- %keybind , ((modMask, xK_Right), sendMessage $ Go R)
-- %keybind , ((modMask, xK_Left), sendMessage $ Go L)
-- %keybind , ((modMask, xK_Up), sendMessage $ Go U)
-- %keybind , ((modMask, xK_Down), sendMessage $ Go D)
-- %layout -- include 'windowNavigation' in defaultLayout definition above.
-- %layout -- just before the list, like the following (don't uncomment next line):
-- %layout -- defaultLayout = SomeLayout $ windowNavigation $ ...
data Navigate = Go Direction deriving ( Read, Show, Typeable )
data Direction = U | D | R | L deriving ( Read, Show, Eq )
instance Message Navigate
data NavigationState a = NS Point [(a,Rectangle)]
data WindowNavigation a = WindowNavigation (Invisible Maybe (NavigationState a)) deriving ( Read, Show )
windowNavigation = ModifiedLayout (WindowNavigation (I Nothing))
instance LayoutModifier WindowNavigation Window where
redoLayout (WindowNavigation (I state)) rscr s wrs =
do XConf { display = dpy, normalBorder = nbc } <- ask
navigableColor <- io $ (Just `fmap` initColor dpy "#0000FF") `catch` \_ -> return Nothing
--uc <- io $ (Just `fmap` initColor dpy "#0000FF") `catch` \_ -> return Nothing
--dc <- io $ (Just `fmap` initColor dpy "#00FFFF") `catch` \_ -> return Nothing
--lc <- io $ (Just `fmap` initColor dpy "#FF0000") `catch` \_ -> return Nothing
--rc <- io $ (Just `fmap` initColor dpy "#FF00FF") `catch` \_ -> return Nothing
--let dirc U = uc
-- dirc D = dc
-- dirc L = lc
-- dirc R = rc
let w = W.focus s
r = case filter ((==w).fst) wrs of ((_,x):_) -> x
[] -> rscr
pt = case state of Just (NS ptold _) | ptold `inrect` r -> ptold
_ -> center r
wrs' = filter ((/=w) . fst) wrs
wnavigable = nub $ concatMap
(\d -> truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L]
--wnavigablec = nub $ concatMap
-- (\d -> map (\(w,_) -> (w,dirc d)) $
-- truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L]
wothers = case state of Just (NS _ wo) -> map fst wo
_ -> []
mapM_ (sc (Just nbc)) (wothers \\ map fst wnavigable)
mapM_ (sc navigableColor) $ map fst wnavigable
--mapM_ (\(w,c) -> sc c w) wnavigablec
return (wrs, Just $ WindowNavigation $ I $ Just $ NS pt wnavigable)
handleMess (WindowNavigation (I (Just (NS pt wrs)))) m
| Just (Go d) <- fromMessage m =
case sortby d $ filter (inr d pt . snd) wrs of
[] -> return Nothing
((w,r):_) -> do focus w
return $ Just $ WindowNavigation $ I $ Just $
NS (centerd d pt r) wrs
| Just Hide <- fromMessage m =
do XConf { display = dpy, normalBorder = nbc } <- ask
mapM_ (sc (Just nbc) . fst) wrs
return $ Just $ WindowNavigation $ I $ Just $ NS pt []
| Just ReleaseResources <- fromMessage m =
handleMess (WindowNavigation (I $ Just (NS pt wrs))) (SomeMessage Hide)
handleMess _ _ = return Nothing
truncHead (x:_) = [x]
truncHead [] = []
sc mc win = do dpy <- asks display
case mc of Just c -> io $ setWindowBorder dpy win c
Nothing -> return ()
center (Rectangle x y w h) = P (fromIntegral x + fromIntegral w/2) (fromIntegral y + fromIntegral h/2)
centerd d (P xx yy) (Rectangle x y w h) | d == U || d == D = P xx (fromIntegral y + fromIntegral h/2)
| otherwise = P (fromIntegral x + fromIntegral w/2) yy
inr D (P x y) (Rectangle l yr w h) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w &&
y < fromIntegral yr + fromIntegral h
inr U (P x y) (Rectangle l yr w _) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w &&
y > fromIntegral yr
inr R (P a x) (Rectangle b l _ w) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w &&
a < fromIntegral b
inr L (P a x) (Rectangle b l c w) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w &&
a > fromIntegral b + fromIntegral c
inrect (P x y) (Rectangle a b w h) = x > fromIntegral a && x < fromIntegral a + fromIntegral w &&
y > fromIntegral b && y < fromIntegral b + fromIntegral h
sortby U = sortBy (\(_,Rectangle _ y _ _) (_,Rectangle _ y' _ _) -> compare y' y)
sortby D = sortBy (\(_,Rectangle _ y _ _) (_,Rectangle _ y' _ _) -> compare y y')
sortby R = sortBy (\(_,Rectangle x _ _ _) (_,Rectangle x' _ _ _) -> compare x x')
sortby L = sortBy (\(_,Rectangle x _ _ _) (_,Rectangle x' _ _ _) -> compare x' x)
data Point = P Double Double
|
