make everything work with new doLayout.

This modifies all the contrib modules to work (so far as I know) with the
new contrib layout.  The exception is the LayoutHooks module, which isn't
used.  It exports an API that is inherently unsafe, so far as I can tell
(and always has been).

Accordion.hs

@@ -31,10 +31,11 @@ import XMonadContrib.LayoutHelpers ( idModify )
 accordion :: Eq a => Layout a
 accordion = Layout { doLayout = accordionLayout, modifyLayout = idModify }
 
-accordionLayout :: Eq a => Rectangle -> W.Stack a -> X [(a, Rectangle)]
-accordionLayout sc ws = return $ (zip ups tops) ++
+accordionLayout :: Eq a => Rectangle -> W.Stack a -> X ([(a, Rectangle)], Maybe (Layout a))
+accordionLayout sc ws = return ((zip ups tops) ++
                                 [(W.focus ws, mainPane)] ++
                                 (zip dns bottoms)
+                               ,Nothing)
  where ups    = W.up ws
        dns    = W.down ws
        (top, allButTop) = splitVerticallyBy (1%8) sc

Circle.hs

@@ -22,14 +22,16 @@ import Graphics.X11.Xlib
 import XMonad
 import StackSet (integrate, Stack(..))
 
+import XMonadContrib.LayoutHelpers ( idModify )
+
 -- $usage
 -- You can use this module with the following in your Config.hs file:
 --
 -- > import XMonadContrib.Circle
 
 circle :: Layout a
-circle = Layout { doLayout = \r s -> return . raise (length (up s)) . circleLayout r $ integrate s,
-                  modifyLayout = return . const Nothing }
+circle = Layout { doLayout = \r s -> return (raise (length (up s)) . circleLayout r $ integrate s, Nothing),
+                  modifyLayout = idModify }
 
 circleLayout :: Rectangle -> [a] -> [(a, Rectangle)]
 circleLayout _ []     = []

Combo.hs

@@ -18,9 +18,9 @@ module XMonadContrib.Combo (
                             combo
                            ) where
 
+import Data.Maybe ( isJust )
 import XMonad
 import StackSet ( integrate, differentiate )
-import Operations ( UnDoLayout(UnDoLayout) )
 
 -- $usage
 --
@@ -37,10 +37,11 @@ import Operations ( UnDoLayout(UnDoLayout) )
 
 combo :: [(Layout a, Int)] -> Layout a -> Layout a
 combo origls super = Layout { doLayout = \r s -> arrange r (integrate s), modifyLayout = message }
-    where arrange _ [] = return []
-          arrange r [w] = return [(w,r)]
+    where arrange _ [] = return ([], Nothing)
+          arrange r [w] = return ([(w,r)], Nothing)
           arrange rinput origws =
-              do rs <- map snd `fmap` runLayout super rinput (differentiate $ take (length origls) origws)
+              do rs <- (map snd . fst) `fmap`
+                       runLayout super rinput (differentiate $ take (length origls) origws)
                  let wss [] _ = []
                      wss [_] ws = [ws]
                      wss (n:ns) ws = take len1 ws : wss ns (drop len1 ws)
@@ -48,13 +49,16 @@ combo origls super = Layout { doLayout = \r s -> arrange r (integrate s), modify
                  out <- sequence $ zipWith3 runLayout (map fst origls) rs
                                                       (map differentiate $
                                                        wss (take (length rs) $ map snd origls) origws)
-                 return $ concat out
-          message m = case fromMessage m of
-                        Just UnDoLayout -> fmap (\(super':ls') -> Just $ combo (zip ls' $ map snd origls) super')
-                                                (broadcastPrivate UnDoLayout (super:map fst origls))
-                        _               -> fmap (maybe Nothing (Just . combo origls)) (modifyLayout super m)
+                 let origls' = zipWith foo (out++repeat ([],Nothing)) origls
+                     foo (_, Nothing) x = x
+                     foo (_, Just l') (_, n) = (l', n)
+                 return (concat $ map fst out, Just $ combo origls' super)
+          message m = do mls <- broadcastPrivate m (super:map fst origls)
+                         return $ (\(super':ls') -> combo (zip ls' $ map snd origls) super') `fmap` mls
 
-broadcastPrivate :: Message a => a -> [Layout b] -> X [Layout b]
-broadcastPrivate a ol = mapM f ol
-    where f l = do ml' <- modifyLayout l (SomeMessage a) `catchX` return (Just l)
-                   return $ maybe l id ml'
+broadcastPrivate :: SomeMessage -> [Layout b] -> X (Maybe [Layout b])
+broadcastPrivate a ol = do nml <- mapM f ol
+                           if any isJust nml
+                              then return $ Just $ zipWith ((flip maybe) id) ol nml
+                              else return Nothing
+    where f l = modifyLayout l a `catchX` return Nothing

Decoration.hs

@@ -24,7 +24,7 @@ import Control.Monad.Reader ( asks )
 import Graphics.X11.Xlib
 import Graphics.X11.Xlib.Extras ( Event(AnyEvent,ButtonEvent), ev_subwindow, ev_event_type, ev_window )
 
-import XMonadContrib.LayoutHooks
+import XMonadContrib.LayoutHelpers ( ModLay, layoutModify, idModDo )
 
 import XMonad
 import Operations ( UnDoLayout(UnDoLayout) )
@@ -33,19 +33,19 @@ import Operations ( UnDoLayout(UnDoLayout) )
 -- You can use this module for writing other extensions.
 -- See, for instance, "XMonadContrib.Tabbed"
 
-newDecoration :: Window -> Rectangle -> Int -> Pixel -> Pixel -> String
-              -> (Display -> Window -> GC -> FontStruct -> X ()) -> X () -> X Window
-newDecoration decfor (Rectangle x y w h) th fg bg fn draw click = do
+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
     win <- io $ createSimpleWindow d rt x y w h (fromIntegral th) fg bg
     io $ selectInput d win $ exposureMask .|. buttonPressMask
     io $ mapWindow d win
 
-    let hook                                          :: SomeMessage -> X Bool
-        hook sm  | Just e <- fromMessage sm           = handle_event e >> return True
-                 | Just UnDoLayout == fromMessage sm  = io (destroyWindow d win) >> return False
-                 | otherwise                          = return True
+    let hook :: SomeMessage -> X (Maybe (ModLay a))
+        hook sm  | Just e <- fromMessage sm           = handle_event e >> return Nothing
+                 | Just UnDoLayout == fromMessage sm  = io (destroyWindow d win) >> return (Just id)
+                 | otherwise                          = return Nothing
 
         handle_event (ButtonEvent {ev_subwindow = thisw,ev_event_type = t})
             | t == buttonPress && thisw == win        = click
@@ -56,9 +56,7 @@ newDecoration decfor (Rectangle x y w h) th fg bg fn draw click = do
             | thisw == decfor && t == propertyNotify  = withGC win fn draw
         handle_event _ = return ()
 
-    addLayoutMessageHook hook
-
-    return win
+    return $ layoutModify idModDo hook l
 
 -- FIXME: withGC should use bracket (but can't, unless draw is an IO thing)
 withGC :: Drawable -> String -> (Display -> Drawable -> GC -> FontStruct -> X ()) -> X ()

HintedTile.hs

@@ -44,7 +44,8 @@ tall = tile splitHorizontally divideVertically
 tile split divide nmaster delta frac =
     Layout { doLayout     = \r w' -> let w = W.integrate w'
                                      in do { hints <- sequence (map getHints w)
-                                           ; return $ zip w (tiler frac r `uncurry` splitAt nmaster hints) }
+                                           ; return (zip w (tiler frac r `uncurry` splitAt nmaster hints)
+                                                    , Nothing) }
            , modifyLayout = \m -> return $ fmap resize     (fromMessage m) `mplus`
                                            fmap incmastern (fromMessage m) }
 

LayoutHelpers.hs

@@ -17,7 +17,7 @@ module XMonadContrib.LayoutHelpers (
     DoLayout, ModDo, ModMod, ModLay,
     layoutModify,
     l2lModDo, idModify,
-    idModMod,
+    idModDo, idModMod,
     ) where
 
 import Graphics.X11.Xlib ( Rectangle )
@@ -27,8 +27,7 @@ import StackSet ( Stack, integrate )
 -- $usage
 -- Use LayoutHelpers to help write easy Layouts.
 
---type DoLayout a = Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (Layout a))
-type DoLayout a = Rectangle -> Stack a -> X [(a, Rectangle)]
+type DoLayout a = Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (Layout a))
 type ModifyLayout a = SomeMessage -> X (Maybe (Layout a))
 
 type ModDo a = Rectangle -> Stack a -> [(a, Rectangle)] -> X ([(a, Rectangle)], Maybe (ModLay a))
@@ -38,16 +37,12 @@ type ModLay a = Layout a -> Layout a
 
 layoutModify :: ModDo a -> ModMod a -> ModLay a
 layoutModify fdo fmod l = Layout { doLayout = dl, modifyLayout = modl }
-    where dl r s = do --(ws, ml') <- doLayout l r s
-                      ws <- doLayout l r s
+    where dl r s = do (ws, ml') <- doLayout l r s
                       (ws', mmod') <- fdo r s ws
-                      --let ml'' = case mmod' of
-                      --           Just mod' -> Just $ mod' $ maybe l id ml'
-                      --           Nothing -> layoutModify fdo mod `fmap` ml'
-                      --return (ws', ml'')
-                      case mmod' of
-                        Just _ -> fail "Sorry, can't yet safely modify layouts in doLayout."
-                        Nothing -> return ws'
+                      let ml'' = case mmod' of
+                                 Just mod' -> Just $ mod' $ maybe l id ml'
+                                 Nothing -> layoutModify fdo fmod `fmap` ml'
+                      return (ws', ml'')
           modl m = do ml' <- modifyLayout l m
                       mmod' <- fmod m
                       return $ case mmod' of
@@ -55,8 +50,10 @@ layoutModify fdo fmod l = Layout { doLayout = dl, modifyLayout = modl }
                                Nothing -> layoutModify fdo fmod `fmap` ml'
 
 l2lModDo :: (Rectangle -> [a] -> [(a,Rectangle)]) -> DoLayout a
---l2lModDo dl r s = return (dl r $ integrate s, Nothing)
-l2lModDo dl r s = return (dl r $ integrate s)
+l2lModDo dl r s = return (dl r $ integrate s, Nothing)
+
+idModDo :: ModDo a
+idModDo _ _ wrs = return (wrs, Nothing)
 
 idModify :: ModifyLayout a
 idModify _ = return Nothing

LayoutHints.hs

@@ -21,6 +21,7 @@ import Graphics.X11.Xlib
 import Graphics.X11.Xlib.Extras ( getWMNormalHints )
 import {-#SOURCE#-} Config (borderWidth)
 import XMonad hiding ( trace )
+import XMonadContrib.LayoutHelpers ( layoutModify, idModMod )
 
 -- $usage
 -- > import XMonadContrib.LayoutHints
@@ -32,12 +33,10 @@ adjBorders             :: Dimension -> D -> D
 adjBorders mult (w,h)  = (w+2*mult*borderWidth, h+2*mult*borderWidth)
 
 layoutHints :: Layout Window -> Layout Window
-layoutHints l = l { doLayout = \r x -> doLayout l r x >>= applyHints
-                  , modifyLayout = \x -> fmap layoutHints `fmap` modifyLayout l x }
-
-applyHints :: [(Window, Rectangle)] -> X [(Window, Rectangle)]
-applyHints xs = mapM applyHint xs
-    where applyHint (w,Rectangle a b c d) =
+layoutHints = layoutModify applyHints idModMod
+    where applyHints _ _ xs = do xs' <- mapM applyHint xs
+                                 return (xs', Nothing)
+          applyHint (w,Rectangle a b c d) =
               withDisplay $ \disp ->
                   do sh <- io $ getWMNormalHints disp w
                      let (c',d') = adjBorders 1 . applySizeHints sh . adjBorders (-1) $ (c,d)

LayoutScreens.hs

@@ -48,7 +48,7 @@ layoutScreens :: Int -> Layout Int -> X ()
 layoutScreens nscr _ | nscr < 1 = trace $ "Can't layoutScreens with only " ++ show nscr ++ " screens."
 layoutScreens nscr l =
     do rtrect <- asks theRoot >>= getWindowRectangle
-       wss <- doLayout l rtrect W.Stack { W.focus=1, W.up=[],W.down=[1..nscr-1] }
+       (wss, _) <- doLayout l rtrect W.Stack { W.focus=1, W.up=[],W.down=[1..nscr-1] }
        modify $ \s -> s { xineScreens = map snd wss
                         , statusGaps  = take nscr $ (statusGaps s) ++ repeat (0,0,0,0) }
 

Magnifier.hs

@@ -24,6 +24,7 @@ module XMonadContrib.Magnifier (
 import Graphics.X11.Xlib
 import XMonad
 import StackSet
+import XMonadContrib.LayoutHelpers
 
 -- $usage
 -- > import XMonadContrib.Magnifier
@@ -31,24 +32,20 @@ import StackSet
 
 -- | Increase the size of the window that has focus, unless it is the master window.
 magnifier :: Eq a => Layout a -> Layout a
-magnifier l = l { doLayout = \r s -> unlessMaster applyMagnifier r s `fmap` doLayout l r s
-                , modifyLayout = \x -> fmap magnifier `fmap` modifyLayout l x }
+magnifier = layoutModify (unlessMaster applyMagnifier) idModMod
 
 -- | Increase the size of the window that has focus, even if it is the master window.
 magnifier' :: Eq a => Layout a -> Layout a
-magnifier' l = l { doLayout = \r s -> applyMagnifier r s `fmap` doLayout l r s
-                 , modifyLayout = \x -> fmap magnifier' `fmap` modifyLayout l x }
+magnifier' = layoutModify applyMagnifier idModMod
 
+unlessMaster :: ModDo a -> ModDo a
+unlessMaster mainmod r s wrs = if null (up s) then return (wrs, Nothing)
+                                              else mainmod r s wrs
 
-type DoLayout = Eq a => Rectangle -> Stack a -> [(a, Rectangle)] -> [(a, Rectangle)]
-
-unlessMaster :: DoLayout -> DoLayout
-unlessMaster f r s = if null (up s) then id else f r s
-
-applyMagnifier :: DoLayout
-applyMagnifier r s = reverse . foldr accumulate []
-    where accumulate (w,wr) ws | w == focus s = ws ++ [(w, shrink r $ magnify wr)]
-                               | otherwise    = (w,wr) : ws
+applyMagnifier :: Eq a => ModDo a
+applyMagnifier r s wrs = return (map mag wrs, Nothing)
+    where mag (w,wr) | w == focus s = (w, shrink r $ magnify wr)
+                     | otherwise = (w,wr)
 
 magnify :: Rectangle -> Rectangle
 magnify (Rectangle x y w h) = Rectangle x' y' w' h'

Mosaic.hs

@@ -87,7 +87,8 @@ flexibility :: Double
 flexibility = 0.1
 
 mosaic :: Double -> Double -> M.Map NamedWindow [WindowHint] -> Layout Window
-mosaic delta tileFrac hints = full { doLayout = \r -> mosaicL tileFrac hints r . W.integrate, modifyLayout = return . mlayout }
+mosaic delta tileFrac hints = full { doLayout = \r -> mosaicL tileFrac hints r . W.integrate
+                                   , modifyLayout = return . mlayout }
     where mlayout x = (m1 `fmap` fromMessage x) `mplus` (m2 `fmap` fromMessage x)
           m1 Shrink = mosaic delta (tileFrac/(1+delta)) hints
           m1 Expand = mosaic delta (tileFrac*(1+delta)) hints
@@ -136,8 +137,8 @@ alterlist f k = M.alter f' k
                            xs' -> Just xs'
 
 mosaicL :: Double -> M.Map NamedWindow [WindowHint]
-        -> Rectangle -> [Window] -> X [(Window, Rectangle)]
-mosaicL _ _ _ [] = return []
+        -> Rectangle -> [Window] -> X ([(Window, Rectangle)],Maybe (Layout Window))
+mosaicL _ _ _ [] = return ([], Nothing)
 mosaicL f hints origRect origws
     = do namedws <- mapM getName origws
          let sortedws = reverse $ map the_value $ sort $ map (\w -> Rated (sumareas [w]) w) namedws
@@ -152,13 +153,13 @@ mosaicL f hints origRect origws
 --             myh2 = maxL $ runCountDown largeNumber $
 --                    sequence $ replicate mediumNumber $
 --                    mosaic_splits one_split origRect Horizontal sortedws
-         return $ map (\(nw,r)->(--trace ("rate1:"++ unlines [show nw,
+         return (map (\(nw,r)->(--trace ("rate1:"++ unlines [show nw,
                                  --                           show $ rate f meanarea (findlist nw hints) r,
                                  --                           show r,
                                  --                           show $ area r/meanarea,
                                  --                           show $ findlist nw hints]) $
                                  unName nw,crop' (findlist nw hints) r)) $
-                flattenMosaic $ the_value $ maxL [myh,myv,myh2,myv2]
+                flattenMosaic $ the_value $ maxL [myh,myv,myh2,myv2], Nothing)
     where mosaic_splits _ _ _ [] = return $ Rated 0 $ M []
           mosaic_splits _ r _ [w] = return $ Rated (rate f meanarea (findlist w hints) r) $ OM (w,r)
           mosaic_splits spl r d ws = maxL `fmap` mapCD (spl r d) (init $ allsplits ws)

SimpleStacking.hs

@@ -21,15 +21,16 @@ module XMonadContrib.SimpleStacking (
                                      simpleStacking
                                     ) where
 
-import Control.Monad.State ( modify )
+import Control.Monad.State ( get )
 import qualified Data.Map as M
 import Data.Maybe ( catMaybes )
 
-import Data.List ( nub, lookup )
-import StackSet ( focus, tag, workspace, current, integrate )
+import Data.List ( nub, lookup, delete )
+import StackSet ( focus, tag, workspace, current, up, down )
 import Graphics.X11.Xlib ( Window )
 
 import XMonad
+import XMonadContrib.LayoutHelpers
 
 -- $usage
 -- You can use this module for 
@@ -39,14 +40,9 @@ simpleStacking :: Layout Window -> Layout Window
 simpleStacking = simpleStacking' []
 
 simpleStacking' :: [Window] -> Layout Window -> Layout Window
-simpleStacking' st l = l { doLayout = dl
-                         , modifyLayout = \m -> fmap (simpleStacking' st) `fmap` modifyLayout l m }
-    where dl r s = do modify $ \ state ->
-                          state { layouts = M.adjust
-                                            (\(_,ss)->(simpleStacking'
-                                                       (focus s:filter (`elem` integrate s) st) l,ss))
-                                            (tag.workspace.current.windowset $ state)
-                                            (layouts state) }
-                      lo <- doLayout l r s
-                      let m = map (\ (w,rr) -> (w,(w,rr))) lo
-                      return $ catMaybes $ map ((flip lookup) m) $ nub (focus s : st ++ map fst lo)
+simpleStacking' st = layoutModify dl idModMod
+    where dl r s wrs = let m = map (\ (w,rr) -> (w,(w,rr))) wrs
+                           wrs' = catMaybes $ map ((flip lookup) m) $
+                                  nub (focus s : st ++ map fst wrs)
+                           st' = focus s:filter (`elem` (up s++down s)) st
+                       in return (wrs', Just (simpleStacking' st'))

Tabbed.hs

@@ -20,7 +20,8 @@ module XMonadContrib.Tabbed (
                             , TConf (..), defaultTConf
                             ) where
 
-import Control.Monad ( forM )
+import Control.Monad ( forM, liftM )
+import Control.Monad.State ( gets )
 
 import Graphics.X11.Xlib
 import XMonad
@@ -29,6 +30,7 @@ import Operations ( focus, initColor )
 import qualified StackSet as W
 
 import XMonadContrib.NamedWindows
+import XMonadContrib.LayoutHelpers ( idModify )
 
 -- $usage
 -- You can use this module with the following in your configuration file:
@@ -50,42 +52,23 @@ import XMonadContrib.NamedWindows
 -- > defaultLayouts = [ simpleStacking $ tabbed shrinkText myconfig
 -- >                 , ... ]
 
-data TConf = 
-    TConf { activeColor :: String
-          , inactiveColor :: String
-          , bgColor :: String
-          , textColor :: String
-          , fontName :: String 
-          , tabSize :: Int
-          } deriving (Show, Read)
+tabbed :: Shrinker -> Layout Window
+tabbed shrinkT =  Layout { doLayout = dolay shrinkT, modifyLayout = const (return Nothing) }
 
-defaultTConf :: TConf
-defaultTConf = 
-    TConf { activeColor ="#BBBBBB"
-          , inactiveColor = "#888888"
-          , bgColor = "#000000"
-          , textColor = "#000000"
-          , fontName = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-          , tabSize = 20
-          }
-
-tabbed :: Shrinker -> TConf -> Layout Window
-tabbed shrinkT config =  Layout { doLayout = dolay shrinkT config, modifyLayout = const (return Nothing) }
-
-dolay :: Shrinker -> TConf -> Rectangle -> W.Stack Window -> X [(Window, Rectangle)]
-dolay _ _ sc (W.Stack w [] []) = return [(w,sc)]
-dolay shr conf sc@(Rectangle x y wid _) s = withDisplay $ \dpy ->
-    do activecolor   <- io $ initColor dpy $ activeColor conf
-       inactivecolor <- io $ initColor dpy $ inactiveColor conf
-       textcolor     <- io $ initColor dpy $ textColor conf 
-       bgcolor       <- io $ initColor dpy $ bgColor conf 
+dolay :: Shrinker -> Rectangle -> W.Stack Window -> X [(Window, Rectangle)]
+dolay _ sc (W.Stack w [] []) = return [(w,sc)]
+dolay shr sc@(Rectangle x y wid _) s = withDisplay $ \dpy ->
+    do activecolor   <- io $ initColor dpy "#BBBBBB"
+       inactivecolor <- io $ initColor dpy "#888888"
+       textcolor     <- io $ initColor dpy "#000000"
+       bgcolor       <- io $ initColor dpy "#000000"
        let ws = W.integrate s
            ts = gentabs conf x y wid (length ws)
            tws = zip ts ws
-           maketab (t,ow) = newDecoration ow t 1 bgcolor activecolor (fontName conf) (drawtab t ow) (focus ow)
-           drawtab r@(Rectangle _ _ wt ht) ow d w' gc fn =
+           maketab (t,ow) = newDecoration ow t 1 bgcolor activecolor (drawtab t ow) (focus ow)
+           drawtab r@(Rectangle _ _ wt ht) ow d w' gc =
                do nw <- getName ow
-                  let tabcolor = if W.focus s == ow then activecolor else inactivecolor
+                  tabcolor <- (maybe inactivecolor (\focusw -> if focusw == ow then activecolor else inactivecolor) . W.peek) `liftM` gets windowset
                   io $ setForeground d gc tabcolor
                   io $ fillRectangles d w' gc [Rectangle 0 0 wt ht]
                   io $ setForeground d gc textcolor
@@ -99,7 +82,7 @@ dolay shr conf sc@(Rectangle x y wid _) s = withDisplay $ \dpy ->
                          (fromIntegral (wt `div` 2) - fromIntegral (width `div` 2))
                          ((fromIntegral ht + fromIntegral asc) `div` 2) name'
        forM tws maketab
-       return [(W.focus s, shrink conf sc)]
+       return $ map (\w -> (w,shrink sc)) ws
 
 type Shrinker = String -> [String]
 

TwoPane.hs

@@ -35,7 +35,7 @@ import StackSet ( focus, up, down)
 -- > twoPane defaultDelta (1%2)
 
 twoPane :: Rational -> Rational -> Layout a
-twoPane delta split = Layout { doLayout = \r s -> return $ arrange r s, modifyLayout = message }
+twoPane delta split = Layout { doLayout = \r s -> return (arrange r s,Nothing), modifyLayout = message }
  where
     arrange rect st = case reverse (up st) of
                         (master:_) -> [(master,left),(focus st,right)]