aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Decoration.hs56
-rw-r--r--LayoutHooks.hs31
2 files changed, 59 insertions, 28 deletions
diff --git a/Decoration.hs b/Decoration.hs
index e31c93f..d939be6 100644
--- a/Decoration.hs
+++ b/Decoration.hs
@@ -1,43 +1,43 @@
module XMonadContrib.Decoration ( newDecoration ) where
-import qualified Data.Map as M
import Data.Bits ( (.|.) )
import Control.Monad.Reader ( asks )
-import Control.Monad.State ( modify, gets )
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras ( Event(AnyEvent,ButtonEvent), ev_subwindow, ev_event_type, ev_window )
+import XMonadContrib.LayoutHooks
+
import XMonad
import Operations ( ModifyWindows(ModifyWindows) )
-import qualified StackSet as W
newDecoration :: Window -> Rectangle -> Int -> Pixel -> Pixel
-> (Display -> Window -> GC -> X ()) -> X () -> X Window
-newDecoration decfor (Rectangle x y w h) th fg bg draw click =
- do d <- asks display
- rt <- asks theRoot
- n <- (W.tag . W.workspace . W.current) `fmap` gets windowset
- Just (l,ls) <- M.lookup n `fmap` gets layouts
- win <- io $ createSimpleWindow d rt x y w h (fromIntegral th) fg bg
- io $ selectInput d win $ exposureMask .|. buttonPressMask
- io $ mapWindow d win
- let draw' = withGC win draw
- modml :: (SomeMessage -> X (Maybe Layout)) -> SomeMessage -> X (Maybe Layout)
- modml oldml m | Just ModifyWindows == fromMessage m = io (destroyWindow d win) >> oldml m
- | Just e <- fromMessage m = handle_event e >> oldml m
- | otherwise = fmap modl `fmap` oldml m
- modl :: Layout -> Layout
- modl oldl = oldl { modifyLayout = modml (modifyLayout oldl) }
- handle_event (ButtonEvent {ev_subwindow = thisw,ev_event_type = t})
- | t == buttonPress && thisw == win = click
- handle_event (ButtonEvent {ev_window = thisw,ev_event_type = t})
- | t == buttonPress && thisw == win = click
- handle_event (AnyEvent {ev_window = thisw, ev_event_type = t})
- | thisw == win && t == expose = draw'
- | thisw == decfor && t == propertyNotify = draw'
- handle_event _ = return ()
- modify $ \s -> s { layouts = M.insert n (modl l,ls) (layouts s) }
- return win
+newDecoration decfor (Rectangle x y w h) th fg bg draw click = do
+ d <- asks display
+ rt <- asks theRoot
+ win <- io $ createSimpleWindow d rt x y w h (fromIntegral th) fg bg
+ io $ selectInput d win $ exposureMask .|. buttonPressMask
+ io $ mapWindow d win
+
+ trace $ "created decoration " ++ show win
+
+ let hook :: SomeMessage -> X Bool
+ hook sm | Just e <- fromMessage sm = handle_event e >> (trace $ "handle even " ++ show win ++ show e) >> return True
+ | Just ModifyWindows == fromMessage sm = io (destroyWindow d win) >> (trace $ "destroyed decoration " ++ show win) >> return False
+ | otherwise = (trace $ "something weird " ++ show win) >> return True
+
+ handle_event (ButtonEvent {ev_subwindow = thisw,ev_event_type = t})
+ | t == buttonPress && thisw == win = click
+ handle_event (ButtonEvent {ev_window = thisw,ev_event_type = t})
+ | t == buttonPress && thisw == win = click
+ handle_event (AnyEvent {ev_window = thisw, ev_event_type = t})
+ | thisw == win && t == expose = withGC win draw
+ | thisw == decfor && t == propertyNotify = withGC win draw
+ handle_event _ = return ()
+
+ addLayoutMessageHook hook
+
+ return win
-- FIXME: withGC should use bracket (but can't, unless draw is an IO thing)
withGC :: Drawable -> (Display -> Drawable -> GC -> X ()) -> X ()
diff --git a/LayoutHooks.hs b/LayoutHooks.hs
new file mode 100644
index 0000000..da66761
--- /dev/null
+++ b/LayoutHooks.hs
@@ -0,0 +1,31 @@
+module XMonadContrib.LayoutHooks ( addLayoutMessageHook ) where
+
+import qualified Data.Map as M ( adjust )
+import Control.Arrow ( first )
+import Control.Monad.State ( modify )
+
+import XMonad
+import qualified StackSet as W
+
+install :: (SomeMessage -> X Bool) -> Layout -> Layout
+install hk lay = lay{ modifyLayout = mod' }
+ where
+ mod' msg = do reinst <- hk msg
+ nlay <- modifyLayout lay msg
+
+ return $ cond_reinst reinst nlay
+
+ -- no need to make anything change
+ cond_reinst True Nothing = Nothing
+ -- reinstall
+ cond_reinst True (Just nlay) = Just (install hk nlay)
+ -- restore inner layout
+ cond_reinst False Nothing = Just lay
+ -- let it rot
+ cond_reinst False (Just nlay) = Just nlay
+
+-- Return True each time you want the hook reinstalled
+addLayoutMessageHook :: (SomeMessage -> X Bool) -> X ()
+addLayoutMessageHook hk = modify $ \ s ->
+ let nr = W.tag . W.workspace . W.current . windowset $ s
+ in s { layouts = M.adjust (first $ install hk) nr (layouts s) }