allow layout modifiers to modify a Message in transit.

This is a helpful feature (for, e.g. WindowNavigation) that
allows modifiers (if they so choose... the old API remains
supported) to easily send a single Message to the modified
layout in response to a Message.

darcs-hash:20071020191542-72aca-fd6b8f2edb91519b4e475319c2bc8c3d4b77136d.gz

1 files changed, 9 insertions, 4 deletions

diff --git a/LayoutModifier.hs b/LayoutModifier.hs
index 88eed93..3c30ec8 100644
--- a/LayoutModifier.hs
+++ b/LayoutModifier.hs
@@ -34,6 +34,9 @@ class (Show (m a), Read (m a)) => LayoutModifier m a where
                         | Just ReleaseResources <- fromMessage mess = doUnhook
                         | otherwise = return Nothing
      where doUnhook = do unhook m; return Nothing
+    handleMessOrMaybeModifyIt :: m a -> SomeMessage -> X (Maybe (Either (m a) SomeMessage))
+    handleMessOrMaybeModifyIt m mess = do mm' <- handleMess m mess
+                                          return (Left `fmap` mm')
     redoLayout :: m a -> Rectangle -> Stack a -> [(a, Rectangle)]
                -> X ([(a, Rectangle)], Maybe (m a))
     redoLayout m _ _ wrs = do hook m; return (wrs, Nothing)
@@ -53,11 +56,13 @@ instance (LayoutModifier m a, LayoutClass l a) => LayoutClass (ModifiedLayout m
                       Nothing -> ModifiedLayout m `fmap` ml'
            return (ws', ml'')
     handleMessage (ModifiedLayout m l) mess =
-        do ml' <- handleMessage l mess
-           mm' <- handleMess m mess
+        do mm' <- handleMessOrMaybeModifyIt m mess
+           ml' <- case mm' of
+                  Just (Right mess') -> handleMessage l mess'
+                  _ -> handleMessage l mess
            return $ case mm' of
-                    Just m' -> Just $ (ModifiedLayout m') $ maybe l id ml'
-                    Nothing -> (ModifiedLayout m) `fmap` ml'
+                    Just (Left m') -> Just $ (ModifiedLayout m') $ maybe l id ml'
+                    _ -> (ModifiedLayout m) `fmap` ml'
     description (ModifiedLayout m l) = modifierDescription m <> description l
      where "" <> x = x
            x <> y = x ++ " " ++ y