enable color setting in WindowNavigation.

This is still somewhat experimental, comments welcome.

darcs-hash:20070929114531-72aca-344bc38c7ffdda5d0421b0746f308c11b18347b4.gz

1 files changed, 56 insertions, 30 deletions

diff --git a/WindowNavigation.hs b/WindowNavigation.hs
index 9e44182..5f3e643 100644
--- a/WindowNavigation.hs
+++ b/WindowNavigation.hs
@@ -21,11 +21,11 @@ module XMonadContrib.WindowNavigation (
                                   ) where
 
 import Graphics.X11.Xlib ( Rectangle(..), Window, setWindowBorder )
-import Control.Monad.Reader ( asks )
+import Control.Monad.Reader ( ask, asks )
 import Data.List ( nub, sortBy, (\\) )
 import XMonad
 import qualified StackSet as W
-import Operations ( focus, initColor )
+import Operations ( focus, initColor, LayoutMessages(..) )
 import XMonadContrib.LayoutModifier
 import XMonadContrib.Invisible
 
@@ -64,44 +64,70 @@ data WindowNavigation a = WindowNavigation (Invisible Maybe (NavigationState a))
 windowNavigation = ModifiedLayout (WindowNavigation (I Nothing))
 
 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
+    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 I (Just (NS ptold _)) | ptold `inrect` r -> ptold
+               pt = case state of Just (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 $ I $ Just $ NS pt 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)
+
     modifyModify (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) []
+        | 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 =
+               modifyModify (WindowNavigation (I $ Just (NS pt wrs))) (SomeMessage Hide)
     modifyModify _ _ = 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
+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')