diff options
| -rw-r--r-- | Decoration.hs | 56 | ||||
| -rw-r--r-- | LayoutHooks.hs | 31 |
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) } |