From 1c8583a687d91bc8cf18e1e51cfc8c796a56c2a1 Mon Sep 17 00:00:00 2001 From: Andrea Rossato Date: Wed, 3 Oct 2007 11:00:17 +0200 Subject: WindowNavigation: add configurable colors and the possibility to turn them off darcs-hash:20071003090017-32816-7dd8786e96e4f766de8fbff6a387fbbde15e67ce.gz --- WindowNavigation.hs | 118 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 68 insertions(+), 50 deletions(-) (limited to 'WindowNavigation.hs') diff --git a/WindowNavigation.hs b/WindowNavigation.hs index 91c1880..18cec76 100644 --- a/WindowNavigation.hs +++ b/WindowNavigation.hs @@ -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 :: 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 + 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 + 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') -- cgit v1.2.3