From 8d8462bac5c9970fd657ad950fb0fc6d7758d20f Mon Sep 17 00:00:00 2001 From: David Roundy Date: Fri, 28 Sep 2007 15:19:06 +0200 Subject: add new WindowNavigation module. darcs-hash:20070928131906-72aca-85996bdc08e931e3a84f57a86bd1ad1b6b4fa650.gz --- WindowNavigation.hs | 114 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 114 insertions(+) create mode 100644 WindowNavigation.hs (limited to 'WindowNavigation.hs') diff --git a/WindowNavigation.hs b/WindowNavigation.hs new file mode 100644 index 0000000..ffc8df9 --- /dev/null +++ b/WindowNavigation.hs @@ -0,0 +1,114 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonadContrib.WorkspaceDir +-- Copyright : (c) 2007 David Roundy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- 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 ( asks ) +import Data.List ( nub, sortBy, (\\) ) +import XMonad +import qualified StackSet as W +import Operations ( focus, initColor ) +import XMonadContrib.LayoutModifier + +-- $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 InvisibleMaybe a = INothin | IJus a +instance Show (InvisibleMaybe a) where show _ = "" +instance Read (InvisibleMaybe a) where readsPrec _ s = [(INothin, s)] + +data NavigationState a = NS Point [(a,Rectangle)] + +data WindowNavigation a = WindowNavigation (InvisibleMaybe (NavigationState a)) deriving ( Read, Show ) + +windowNavigation = ModifiedLayout (WindowNavigation INothin) + +instance LayoutModifier WindowNavigation Window where + redoLayout (WindowNavigation state) rscr s wrs = + do dpy <- asks display + --navigableColor <- io $ (Just `fmap` initColor dpy "#0000FF") `catch` \_ -> return Nothing + --otherColor <- io $ (Just `fmap` initColor dpy "#000000") `catch` \_ -> return Nothing + let sc mc win = case mc of + Just c -> io $ setWindowBorder dpy win c + Nothing -> return () + w = W.focus s + r = case filter ((==w).fst) wrs of ((_,x):_) -> x + [] -> rscr + pt = case state of IJus (NS ptold _) | ptold `inrect` r -> ptold + _ -> center r + wrs' = filter ((/=w) . fst) wrs + wnavigable = nub $ map fst $ concatMap (\d -> filter (inr d pt . snd) wrs') [U,D,R,L] + wothers = map fst wrs' \\ wnavigable + --mapM_ (sc navigableColor) wnavigable + --mapM_ (sc otherColor) wothers + return (wrs, Just $ WindowNavigation $ IJus $ NS pt wrs') + modifyModify (WindowNavigation (IJus (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 $ IJus $ NS (centerd d pt r) [] + modifyModify _ _ = return Nothing + +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 -- cgit v1.2.3