twin/xmonad-contrib
1
0
Fork 0
mirror of https://github.com/xmonad/xmonad-contrib.git synced 2025-08-12 02:35:59 -07:00
Code Issues Packages Projects Releases Wiki Activity

WindowNavigation: add configurable colors and the possibility to turn them off

Browse Source
This commit is contained in:
Andrea Rossato
2007-10-03 09:00:17 +00:00
parent d60c48238e
commit e8bd7919fa
1 changed files with 70 additions and 52 deletions
Download Patch File Download Diff File Expand all files Collapse all files

88
WindowNavigation.hs
View File

@@ -17,24 +17,27 @@ module XMonadContrib.WindowNavigation (
-- * Usage -- * Usage
-- $usage -- $usage
windowNavigation, windowNavigation,
Navigate(..), Direction(..) Navigate(..), Direction(..),
WNConfig (..), defaultWNConfig
) where ) where
import Graphics.X11.Xlib ( Rectangle(..), Window, setWindowBorder ) import Graphics.X11.Xlib ( Rectangle(..), Window, Pixel, setWindowBorder )
import Control.Monad.Reader ( ask, asks ) import Control.Monad ( when )
import Control.Monad.Reader ( ask )
import Data.List ( nub, sortBy, (\\) ) import Data.List ( nub, sortBy, (\\) )
import XMonad import XMonad
import qualified StackSet as W import qualified StackSet as W
import Operations ( focus, initColor, LayoutMessages(..) ) import Operations ( focus, LayoutMessages(..) )
import XMonadContrib.LayoutModifier import XMonadContrib.LayoutModifier
import XMonadContrib.Invisible import XMonadContrib.Invisible
import XMonadContrib.XUtils
-- $usage -- $usage
-- You can use this module with the following in your Config.hs file: -- You can use this module with the following in your Config.hs file:
-- --
-- > import XMonadContrib.WindowNavigation -- > import XMonadContrib.WindowNavigation
-- > -- >
-- > defaultLayout = SomeLayout $ windowNavigation $ LayoutSelection ... -- > defaultLayout = SomeLayout $ windowNavigation defaultWNConfig $ LayoutSelection ...
-- --
-- In keybindings: -- In keybindings:
-- --
@@ -50,31 +53,39 @@ import XMonadContrib.Invisible
-- %keybind , ((modMask, xK_Down), sendMessage $ Go D) -- %keybind , ((modMask, xK_Down), sendMessage $ Go D)
-- %layout -- include 'windowNavigation' in defaultLayout definition above. -- %layout -- include 'windowNavigation' in defaultLayout definition above.
-- %layout -- just before the list, like the following (don't uncomment next line): -- %layout -- just before the list, like the following (don't uncomment next line):
-- %layout -- defaultLayout = SomeLayout $ windowNavigation $ ... -- %layout -- defaultLayout = SomeLayout $ windowNavigation defaultWNConfig $ ...
data Navigate = Go Direction deriving ( Read, Show, Typeable ) data Navigate = Go Direction deriving ( Read, Show, Typeable )
data Direction = U | D | R | L deriving ( Read, Show, Eq ) data Direction = U | D | R | L deriving ( Read, Show, Eq )
instance Message Navigate instance Message Navigate
data WNConfig =
WNC { showNavigable :: Bool
, upColor :: String
, downColor :: String
, leftColor :: String
, rightColor :: String
} deriving (Show, Read)
defaultWNConfig :: WNConfig
defaultWNConfig = WNC True "#0000FF" "#00FFFF" "#FF0000" "#FF00FF"
data NavigationState a = NS Point [(a,Rectangle)] data NavigationState a = NS Point [(a,Rectangle)]
data WindowNavigation a = WindowNavigation (Invisible Maybe (NavigationState a)) deriving ( Read, Show ) data WindowNavigation a = WindowNavigation WNConfig (Invisible Maybe (NavigationState a)) deriving ( Read, Show )
windowNavigation = ModifiedLayout (WindowNavigation (I Nothing)) windowNavigation :: LayoutClass l a => WNConfig -> l a -> ModifiedLayout WindowNavigation l a
windowNavigation conf = ModifiedLayout (WindowNavigation conf (I Nothing))
instance LayoutModifier WindowNavigation Window where instance LayoutModifier WindowNavigation Window where
redoLayout (WindowNavigation (I state)) rscr s wrs = redoLayout (WindowNavigation conf (I state)) rscr s wrs =
do XConf { display = dpy, normalBorder = nbc } <- ask do XConf { normalBorder = nbc } <- ask
navigableColor <- io $ (Just `fmap` initColor dpy "#0000FF") `catch` \_ -> return Nothing [uc,dc,lc,rc] <- mapM stringToPixel [upColor conf, downColor conf, leftColor conf, rightColor conf]
--uc <- io $ (Just `fmap` initColor dpy "#0000FF") `catch` \_ -> return Nothing let dirc U = uc
--dc <- io $ (Just `fmap` initColor dpy "#00FFFF") `catch` \_ -> return Nothing dirc D = dc
--lc <- io $ (Just `fmap` initColor dpy "#FF0000") `catch` \_ -> return Nothing dirc L = lc
--rc <- io $ (Just `fmap` initColor dpy "#FF00FF") `catch` \_ -> return Nothing dirc R = rc
--let dirc U = uc
-- dirc D = dc
-- dirc L = lc
-- dirc R = rc
let w = W.focus s let w = W.focus s
r = case filter ((==w).fst) wrs of ((_,x):_) -> x r = case filter ((==w).fst) wrs of ((_,x):_) -> x
[] -> rscr [] -> rscr
@@ -83,41 +94,45 @@ instance LayoutModifier WindowNavigation Window where
wrs' = filter ((/=w) . fst) wrs wrs' = filter ((/=w) . fst) wrs
wnavigable = nub $ concatMap wnavigable = nub $ concatMap
(\d -> truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L] (\d -> truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L]
--wnavigablec = nub $ concatMap wnavigablec = nub $ concatMap
-- (\d -> map (\(w,_) -> (w,dirc d)) $ (\d -> map (\(win,_) -> (win,dirc d)) $
-- truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L] truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L]
wothers = case state of Just (NS _ wo) -> map fst wo wothers = case state of Just (NS _ wo) -> map fst wo
_ -> [] _ -> []
mapM_ (sc (Just nbc)) (wothers \\ map fst wnavigable) mapM_ (sc nbc) (wothers \\ map fst wnavigable)
mapM_ (sc navigableColor) $ map fst wnavigable when (showNavigable conf) $ mapM_ (\(win,c) -> sc c win) wnavigablec
--mapM_ (\(w,c) -> sc c w) wnavigablec return (wrs, Just $ WindowNavigation conf $ I $ Just $ NS pt wnavigable)
return (wrs, Just $ WindowNavigation $ I $ Just $ NS pt wnavigable)
handleMess (WindowNavigation (I (Just (NS pt wrs)))) m handleMess (WindowNavigation conf (I (Just (NS pt wrs)))) m
| Just (Go d) <- fromMessage m = | Just (Go d) <- fromMessage m =
case sortby d $ filter (inr d pt . snd) wrs of case sortby d $ filter (inr d pt . snd) wrs of
[] -> return Nothing [] -> return Nothing
((w,r):_) -> do focus w ((w,r):_) -> do focus w
return $ Just $ WindowNavigation $ I $ Just $ return $ Just $ WindowNavigation conf $ I $ Just $
NS (centerd d pt r) wrs NS (centerd d pt r) wrs
| Just Hide <- fromMessage m = | Just Hide <- fromMessage m =
do XConf { display = dpy, normalBorder = nbc } <- ask do XConf { normalBorder = nbc } <- ask
mapM_ (sc (Just nbc) . fst) wrs mapM_ (sc nbc . fst) wrs
return $ Just $ WindowNavigation $ I $ Just $ NS pt [] return $ Just $ WindowNavigation conf $ I $ Just $ NS pt []
| Just ReleaseResources <- fromMessage m = | Just ReleaseResources <- fromMessage m =
handleMess (WindowNavigation (I $ Just (NS pt wrs))) (SomeMessage Hide) handleMess (WindowNavigation conf (I $ Just (NS pt wrs))) (SomeMessage Hide)
handleMess _ _ = return Nothing handleMess _ _ = return Nothing
truncHead :: [a] -> [a]
truncHead (x:_) = [x] truncHead (x:_) = [x]
truncHead [] = [] truncHead [] = []
sc mc win = do dpy <- asks display sc :: Pixel -> Window -> X ()
case mc of Just c -> io $ setWindowBorder dpy win c sc c win = withDisplay $ \dpy -> io $ setWindowBorder dpy win c
Nothing -> return ()
center :: Rectangle -> Point
center (Rectangle x y w h) = P (fromIntegral x + fromIntegral w/2) (fromIntegral y + fromIntegral h/2) center (Rectangle x y w h) = P (fromIntegral x + fromIntegral w/2) (fromIntegral y + fromIntegral h/2)
centerd :: Direction -> Point -> Rectangle -> Point
centerd d (P xx yy) (Rectangle x y w h) | d == U || d == D = P xx (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 | otherwise = P (fromIntegral x + fromIntegral w/2) yy
inr :: Direction -> Point -> Rectangle -> Bool
inr D (P x y) (Rectangle l yr w h) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w && inr D (P x y) (Rectangle l yr w h) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w &&
y < fromIntegral yr + fromIntegral h y < fromIntegral yr + fromIntegral h
inr U (P x y) (Rectangle l yr w _) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w && inr U (P x y) (Rectangle l yr w _) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w &&
@@ -126,9 +141,12 @@ inr R (P a x) (Rectangle b l _ w) = x >= fromIntegral l && x < fromIntegral l +
a < fromIntegral b a < fromIntegral b
inr L (P a x) (Rectangle b l c w) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w && inr L (P a x) (Rectangle b l c w) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w &&
a > fromIntegral b + fromIntegral c a > fromIntegral b + fromIntegral c
inrect :: Point -> Rectangle -> Bool
inrect (P x y) (Rectangle a b w h) = x > fromIntegral a && x < fromIntegral a + fromIntegral w && 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 y > fromIntegral b && y < fromIntegral b + fromIntegral h
sortby :: Direction -> [(a,Rectangle)] -> [(a,Rectangle)]
sortby U = sortBy (\(_,Rectangle _ y _ _) (_,Rectangle _ y' _ _) -> compare y' y) sortby U = sortBy (\(_,Rectangle _ y _ _) (_,Rectangle _ y' _ _) -> compare y' y)
sortby D = 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 R = sortBy (\(_,Rectangle x _ _ _) (_,Rectangle x' _ _ _) -> compare x x')