Refactor Decoration into a general layout-level hooks interface, and a decoration support module on top of that

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 ()

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) }