Fix MultiToggle crashes with decorated layouts

Ignore-this: 9208f5da9f0de95464ea62cb45e8f291

The problem was that certain layouts keep their "world" state in their value,
which was thrown away and forgotten after ReleaseResources during toggle.

In particular, decorated layouts store some X11 handles in them and
allocate/deallocate it as appropriate. If any modification to their state is
ignored, they may try to deallocate already deallocated memory, which results
in a crash somewhere inside Xlib.

This patch makes Transformers reversible so that nothing is ever ignored. As a
side effect, layout transformers now do receive messages and messages for the
base layout do not need the undo/reapply cycle -- we just pass messages to the
current transformed layout and unapply the transformer when needed.
(This, however, doesn't mean that the base layout is not asked to release
resources on a transformer change -- we still need the transformer to release
its resources and there's no way to do this without asking the base layout as
well.)

darcs-hash:20091220004733-c9ff5-34670f3db8ab715d8f334973d6ea2a3e7f3aed7a.gz

3 files changed, 40 insertions, 68 deletions

diff --git a/XMonad/Layout/MultiToggle.hs b/XMonad/Layout/MultiToggle.hs
index ebf41b0..46716a4 100644
--- a/XMonad/Layout/MultiToggle.hs
+++ b/XMonad/Layout/MultiToggle.hs
@@ -41,11 +41,6 @@ import Data.Maybe
 -- first disables any currently active transformer; i.e. it works like a
 -- group of radio buttons.
 --
--- A side effect of this meta-layout is that layout transformers no longer
--- receive any messages; any message not handled by MultiToggle itself will
--- undo the current layout transformer, pass the message on to the base
--- layout, then reapply the transformer.
---
 -- To use this module, you need some data types which represent
 -- transformers; for some commonly used transformers (including
 -- MIRROR, NOBORDERS, and FULL used in the examples below) you can
@@ -89,7 +84,7 @@ import Data.Maybe
 --
 -- > data MIRROR = MIRROR deriving (Read, Show, Eq, Typeable)
 -- > instance Transformer MIRROR Window where
--- >     transform _ x k = k (Mirror x)
+-- >     transform _ x k = k (Mirror x) (\(Mirror x') -> x')
 --
 -- Note, you need to put @{-\# LANGUAGE DeriveDataTypeable \#-}@ at the
 -- beginning of your file.
@@ -97,15 +92,19 @@ import Data.Maybe
 -- | A class to identify custom transformers (and look up transforming
 -- functions by type).
 class (Eq t, Typeable t) => Transformer t a | t -> a where
-    transform :: (LayoutClass l a) => t -> l a -> (forall l'. (LayoutClass l' a) => l' a -> b) -> b
+    transform :: (LayoutClass l a) => t -> l a ->
+        (forall l'. (LayoutClass l' a) => l' a -> (l' a -> l a) -> b) -> b
+
+data (LayoutClass l a) => EL l a = forall l'. (LayoutClass l' a) => EL (l' a) (l' a -> l a)
 
-data EL a = forall l. (LayoutClass l a) => EL (l a)
+unEL :: (LayoutClass l a) => EL l a -> (forall l'. (LayoutClass l' a) => l' a -> b) -> b
+unEL (EL x _) k = k x
 
-unEL :: EL a -> (forall l. (LayoutClass l a) => l a -> b) -> b
-unEL (EL x) k = k x
+deEL :: (LayoutClass l a) => EL l a -> l a
+deEL (EL x det) = det x
 
-transform' :: (Transformer t a) => t -> EL a -> EL a
-transform' t el = el `unEL` \l -> transform t l EL
+transform' :: (Transformer t a, LayoutClass l a) => t -> EL l a -> EL l a
+transform' t (EL l det) = transform t l (\l' det' -> EL l' (det . det'))
 
 -- | Toggle the specified layout transformer.
 data Toggle a = forall t. (Transformer t a) => Toggle t
@@ -117,10 +116,8 @@ data MultiToggleS ts l a = MultiToggleS (l a) (Maybe Int) ts
     deriving (Read, Show)
 
 data MultiToggle ts l a = MultiToggle{
-    baseLayout :: l a,
-    currLayout :: EL a,
+    currLayout :: EL l a,
     currIndex :: Maybe Int,
-    currTrans :: EL a -> EL a,
     transformers :: ts
 }
 
@@ -128,27 +125,23 @@ expand :: (LayoutClass l a, HList ts a) => MultiToggleS ts l a -> MultiToggle ts
 expand (MultiToggleS b i ts) =
     resolve ts (fromMaybe (-1) i) id
         (\x mt ->
-            let g = transform' x in
-            mt{
-                currLayout = g . EL $ baseLayout mt,
-                currTrans = g
-            }
+            let g = transform' x in mt{ currLayout = g $ currLayout mt }
         )
-        (MultiToggle b (EL b) i id ts)
+        (MultiToggle (EL b id) i ts)
 
-collapse :: MultiToggle ts l a -> MultiToggleS ts l a
-collapse mt = MultiToggleS (baseLayout mt) (currIndex mt) (transformers mt)
+collapse :: (LayoutClass l a) => MultiToggle ts l a -> MultiToggleS ts l a
+collapse mt = MultiToggleS (deEL (currLayout mt)) (currIndex mt) (transformers mt)
 
 instance (LayoutClass l a, Read (l a), HList ts a, Read ts) => Read (MultiToggle ts l a) where
     readsPrec p s = map (first expand) $ readsPrec p s
 
-instance (Show ts, Show (l a)) => Show (MultiToggle ts l a) where
+instance (Show ts, Show (l a), LayoutClass l a) => Show (MultiToggle ts l a) where
     showsPrec p = showsPrec p . collapse
 
 -- | Construct a @MultiToggle@ layout from a transformer table and a base
 -- layout.
 mkToggle :: (LayoutClass l a) => ts -> l a -> MultiToggle ts l a
-mkToggle ts l = MultiToggle l (EL l) Nothing id ts
+mkToggle ts l = MultiToggle (EL l id) Nothing ts
 
 -- | Construct a @MultiToggle@ layout from a single transformer and a base
 -- layout.
@@ -190,48 +183,26 @@ instance (Transformer a w, HList b w) => HList (HCons a b) w where
 geq :: (Typeable a, Eq a, Typeable b) => a -> b -> Bool
 geq a b = Just a == cast b
 
-acceptChange :: (LayoutClass l' a) => MultiToggle ts l a -> ((l' a -> MultiToggle ts l a) -> b -> c) -> X b -> X c
-acceptChange mt f = fmap (f (\x -> mt{ currLayout = EL x }))
-
 instance (Typeable a, Show ts, HList ts a, LayoutClass l a) => LayoutClass (MultiToggle ts l) a where
     description mt = currLayout mt `unEL` \l -> description l
 
-    runLayout (Workspace i mt s) r
-        | isNothing (currIndex mt) =
-            acceptChange mt (fmap . fmap . \f x -> (f x){ baseLayout = x }) $ runLayout (Workspace i (baseLayout mt) s) r
-        | otherwise = currLayout mt `unEL` \l ->
-            acceptChange mt (fmap . fmap) $ runLayout (Workspace i l s) r
+    runLayout (Workspace i mt s) r = case currLayout mt of
+        EL l det -> fmap (fmap . fmap $ (\x -> mt { currLayout = EL x det })) $
+            runLayout (Workspace i l s) r
 
     handleMessage mt m
         | Just (Toggle t) <- fromMessage m
         , i@(Just _) <- find (transformers mt) t
-            = currLayout mt `unEL` \l ->
-            if i == currIndex mt
-                then do
-                    handleMessage l (SomeMessage ReleaseResources)
+            = case currLayout mt of
+                EL l det -> do
+                    l' <- fromMaybe l `fmap` handleMessage l (SomeMessage ReleaseResources)
                     return . Just $
-                        mt{
-                            currLayout = EL $ baseLayout mt,
-                            currIndex = Nothing,
-                            currTrans = id
+                        mt {
+                            currLayout = (if cur then id else transform' t) (EL (det l') id),
+                            currIndex = if cur then Nothing else i
                         }
-                else do
-                    handleMessage l (SomeMessage ReleaseResources)
-                    let f = transform' t
-                    return . Just $
-                        mt{
-                            currLayout = f . EL $ baseLayout mt,
-                            currIndex = i,
-                            currTrans = f
-                        }
-        | fromMessage m == Just ReleaseResources ||
-          fromMessage m == Just Hide
-            = currLayout mt `unEL` \l -> acceptChange mt fmap (handleMessage l m)
-        | otherwise = do
-            ml <- handleMessage (baseLayout mt) m
-            case ml of
-                Nothing -> return Nothing
-                Just b' -> currLayout mt `unEL` \l -> do
-                    handleMessage l (SomeMessage ReleaseResources)
-                    return . Just $
-                        mt{ baseLayout = b', currLayout = currTrans mt . EL $ b' }
+                    where cur = (i == currIndex mt)
+        | otherwise
+            = case currLayout mt of
+                EL l det -> fmap (fmap (\x -> mt { currLayout = EL x det })) $
+                    handleMessage l m
diff --git a/XMonad/Layout/MultiToggle/Instances.hs b/XMonad/Layout/MultiToggle/Instances.hs
index a409aa8..b8112f1 100644
--- a/XMonad/Layout/MultiToggle/Instances.hs
+++ b/XMonad/Layout/MultiToggle/Instances.hs
@@ -22,6 +22,7 @@ import XMonad.Layout.MultiToggle
 
 import XMonad
 import XMonad.Layout.NoBorders
+import XMonad.Layout.LayoutModifier
 
 data StdTransformers = FULL          -- ^ switch to Full layout
                      | NBFULL        -- ^ switch to Full with no borders
@@ -31,8 +32,8 @@ data StdTransformers = FULL          -- ^ switch to Full layout
   deriving (Read, Show, Eq, Typeable)
 
 instance Transformer StdTransformers Window where
-    transform FULL         _ k = k Full
-    transform NBFULL       _ k = k (noBorders Full)
-    transform MIRROR       x k = k (Mirror x)
-    transform NOBORDERS    x k = k (noBorders x)
-    transform SMARTBORDERS x k = k (smartBorders x)
+    transform FULL         x k = k Full (const x)
+    transform NBFULL       x k = k (noBorders Full) (const x)
+    transform MIRROR       x k = k (Mirror x) (\(Mirror x') -> x')
+    transform NOBORDERS    x k = k (noBorders x) (\(ModifiedLayout _ x') -> x')
+    transform SMARTBORDERS x k = k (smartBorders x) (\(ModifiedLayout _ x') -> x')
diff --git a/XMonad/Layout/Reflect.hs b/XMonad/Layout/Reflect.hs
index aed67ac..03fd6b6 100644
--- a/XMonad/Layout/Reflect.hs
+++ b/XMonad/Layout/Reflect.hs
@@ -105,7 +105,7 @@ data REFLECTX = REFLECTX deriving (Read, Show, Eq, Typeable)
 data REFLECTY = REFLECTY deriving (Read, Show, Eq, Typeable)
 
 instance Transformer REFLECTX Window where
-    transform REFLECTX x k = k (reflectHoriz x)
+    transform REFLECTX x k = k (reflectHoriz x) (\(ModifiedLayout _ x') -> x')
 
 instance Transformer REFLECTY Window where
-    transform REFLECTY x k = k (reflectVert x)
\ No newline at end of file
+    transform REFLECTY x k = k (reflectVert x) (\(ModifiedLayout _ x') -> x')