mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-07-31 04:01:51 -07:00
WindowNavigation: add configurable colors and the possibility to turn them off
This commit is contained in:
@@ -17,24 +17,27 @@ module XMonadContrib.WindowNavigation (
|
||||
-- * Usage
|
||||
-- $usage
|
||||
windowNavigation,
|
||||
Navigate(..), Direction(..)
|
||||
Navigate(..), Direction(..),
|
||||
WNConfig (..), defaultWNConfig
|
||||
) where
|
||||
|
||||
import Graphics.X11.Xlib ( Rectangle(..), Window, setWindowBorder )
|
||||
import Control.Monad.Reader ( ask, asks )
|
||||
import Graphics.X11.Xlib ( Rectangle(..), Window, Pixel, setWindowBorder )
|
||||
import Control.Monad ( when )
|
||||
import Control.Monad.Reader ( ask )
|
||||
import Data.List ( nub, sortBy, (\\) )
|
||||
import XMonad
|
||||
import qualified StackSet as W
|
||||
import Operations ( focus, initColor, LayoutMessages(..) )
|
||||
import Operations ( focus, LayoutMessages(..) )
|
||||
import XMonadContrib.LayoutModifier
|
||||
import XMonadContrib.Invisible
|
||||
import XMonadContrib.XUtils
|
||||
|
||||
-- $usage
|
||||
-- You can use this module with the following in your Config.hs file:
|
||||
--
|
||||
-- > import XMonadContrib.WindowNavigation
|
||||
-- >
|
||||
-- > defaultLayout = SomeLayout $ windowNavigation $ LayoutSelection ...
|
||||
-- > defaultLayout = SomeLayout $ windowNavigation defaultWNConfig $ LayoutSelection ...
|
||||
--
|
||||
-- In keybindings:
|
||||
--
|
||||
@@ -50,85 +53,100 @@ import XMonadContrib.Invisible
|
||||
-- %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 $ ...
|
||||
-- %layout -- defaultLayout = SomeLayout $ windowNavigation defaultWNConfig $ ...
|
||||
|
||||
|
||||
data Navigate = Go Direction deriving ( Read, Show, Typeable )
|
||||
data Direction = U | D | R | L deriving ( Read, Show, Eq )
|
||||
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 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
|
||||
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
|
||||
redoLayout (WindowNavigation conf (I state)) rscr s wrs =
|
||||
do XConf { normalBorder = nbc } <- ask
|
||||
[uc,dc,lc,rc] <- mapM stringToPixel [upColor conf, downColor conf, leftColor conf, rightColor conf]
|
||||
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]
|
||||
wnavigablec = nub $ concatMap
|
||||
(\d -> map (\(win,_) -> (win,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)
|
||||
_ -> []
|
||||
mapM_ (sc nbc) (wothers \\ map fst wnavigable)
|
||||
when (showNavigable conf) $ mapM_ (\(win,c) -> sc c win) wnavigablec
|
||||
return (wrs, Just $ WindowNavigation conf $ 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 =
|
||||
case sortby d $ filter (inr d pt . snd) wrs of
|
||||
[] -> return Nothing
|
||||
[] -> return Nothing
|
||||
((w,r):_) -> do focus w
|
||||
return $ Just $ WindowNavigation $ I $ Just $
|
||||
return $ Just $ WindowNavigation conf $ 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 []
|
||||
do XConf { normalBorder = nbc } <- ask
|
||||
mapM_ (sc nbc . fst) wrs
|
||||
return $ Just $ WindowNavigation conf $ I $ Just $ NS pt []
|
||||
| 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
|
||||
|
||||
truncHead :: [a] -> [a]
|
||||
truncHead (x:_) = [x]
|
||||
truncHead [] = []
|
||||
|
||||
sc mc win = do dpy <- asks display
|
||||
case mc of Just c -> io $ setWindowBorder dpy win c
|
||||
Nothing -> return ()
|
||||
sc :: Pixel -> Window -> X ()
|
||||
sc c win = withDisplay $ \dpy -> io $ setWindowBorder dpy win c
|
||||
|
||||
center :: Rectangle -> Point
|
||||
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)
|
||||
| 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
|
||||
|
||||
inr :: Direction -> Point -> Rectangle -> Bool
|
||||
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 :: Point -> Rectangle -> Bool
|
||||
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 :: Direction -> [(a,Rectangle)] -> [(a,Rectangle)]
|
||||
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')
|
||||
|
Reference in New Issue
Block a user