SwitchTrans.hs, initial version

MetaModule.hs

@@ -52,6 +52,7 @@ import XMonadContrib.SinkAll ()
 import XMonadContrib.Spiral ()
 import XMonadContrib.Square ()
 import XMonadContrib.Submap ()
+import XMonadContrib.SwitchTrans ()
 import XMonadContrib.Tabbed ()
 import XMonadContrib.TwoPane ()
 import XMonadContrib.Warp ()

SwitchTrans.hs

@@ -0,0 +1,161 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.SwitchTrans
+-- Copyright   :  (c) Lukas Mai
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  <l.mai@web.de>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+-- | Ordinary layout transformers are simple and easy to use but inflexible.
+-- This module provides a more structured interface to them.
+--
+-- The basic idea is to have a base layout and a set of layout transformers,
+-- of which at most one is active at any time. Enabling another transformer
+-- 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 @SwitchTrans@ itself
+-- will undo the current layout transformer, pass the message on to the base
+-- layout, then reapply the transformer.
+--
+-- Here's how you might use this in Config.hs:
+--
+-- > defaultLayouts =
+-- >     map (
+-- >         mkSwitch (M.singleton "full" (const $ noBorders full)) .
+-- >         mkSwitch (M.singleton "mirror" mirror)
+-- >     ) [ tiled ]
+--
+-- (The noBorders transformer is from @XMonadContrib.NoBorders@.)
+--
+-- This example is probably overkill but it's very close to what I actually use.
+-- Anyway, this layout behaves like the default @tiled@ layout, until you send it
+-- @Enable@\/@Disable@\/@Toggle@ messages. From the definition of @keys@:
+--
+-- > ...
+-- >    , ((modMask,               xK_f     ), sendMessage $ Toggle "full")
+-- >    , ((modMask,               xK_r     ), sendMessage $ Toggle "mirror")
+--
+-- (You may want to use other keys. I don't use Xinerama so the default mod-r
+-- binding is useless to me.)
+--
+-- After this, pressing @mod-f@ switches the current window to fullscreen mode.
+-- Pressing @mod-f@ again switches it back. Similarly, @mod-r@ rotates the layout
+-- by 90 degrees (and back). The nice thing is that your changes are kept:
+-- Rotating first then changing the size of the master area then rotating back
+-- does not undo the master area changes.
+--
+-- The reason I use two stacked @SwitchTrans@ transformers instead of
+-- @mkSwitch (M.fromList [("full", const $ noBorders full), ("mirror", mirror)])@
+-- is that I use @mod-f@ to "zoom in" on interesting windows, no matter what other
+-- layout transformers may be active. Having an extra fullscreen mode on top of
+-- everything else means I can zoom in and out without implicitly undoing "normal"
+-- layout transformers, like @mirror@. Remember, inside a @SwitchTrans@ there can
+-- be at most one active layout transformer.
+module XMonadContrib.SwitchTrans (
+    Toggle(..),
+    Enable(..),
+    Disable(..),
+    mkSwitch
+) where
+
+import XMonad
+import Operations
+
+import qualified Data.Map as M
+import Data.Map (Map)
+
+-- | Toggle the specified layout transformer.
+data Toggle = Toggle String deriving (Eq, Typeable)
+instance Message Toggle
+-- | Enable the specified transformer.
+data Enable = Enable String deriving (Eq, Typeable)
+instance Message Enable
+-- | Disable the specified transformer.
+data Disable = Disable String deriving (Eq, Typeable)
+instance Message Disable
+
+data State a = State {
+    base :: Layout a,
+    currTag :: Maybe String,
+    currLayout :: Layout a,
+    currFilt :: Layout a -> Layout a,
+    filters :: Map String (Layout a -> Layout a)
+}
+
+-- | Take a transformer table and a base layout, and return a
+-- SwitchTrans layout.
+mkSwitch :: Map String (Layout a -> Layout a) -> Layout a -> Layout a
+mkSwitch fs b = switched st
+    where
+    st = State{
+        base = b,
+        currTag = Nothing,
+        currLayout = b,
+        currFilt = id,
+        filters = fs }
+        
+provided :: Bool -> X (Maybe a) -> X (Maybe a)
+provided c x
+    | c = x
+    | otherwise = return Nothing
+
+switched :: State a -> Layout a
+switched
+    state@State{
+        base = b,
+        currTag = ct,
+        currLayout = cl,
+        currFilt = cf,
+        filters = fs
+    } = Layout {doLayout = dl, modifyLayout = ml}
+    where
+    enable tag alt = do
+        modifyLayout cl (SomeMessage UnDoLayout)
+        return . Just . switched $ state{
+            currTag = Just tag,
+            currFilt = alt,
+            currLayout = alt b }
+    disable = do
+        modifyLayout cl (SomeMessage UnDoLayout)
+        return . Just . switched $ state{
+            currTag = Nothing,
+            currFilt = id,
+            currLayout = b }
+    dl r s = do
+        (x, _) <- doLayout cl r s
+        return (x, Nothing)  -- sorry Dave, I can't let you do that
+    ml m
+        | Just (Disable tag) <- fromMessage m
+        , M.member tag fs
+        = provided (ct == Just tag) $ disable
+        | Just (Enable tag) <- fromMessage m
+        , Just alt <- M.lookup tag fs
+        = provided (ct /= Just tag) $ enable tag alt
+        | Just (Toggle tag) <- fromMessage m
+        , Just alt <- M.lookup tag fs
+        =
+            if (ct == Just tag) then
+                disable
+            else
+                enable tag alt
+        | Just UnDoLayout <- fromMessage m
+        = do
+            modifyLayout cl m
+            return Nothing
+        | otherwise = do
+            x <- modifyLayout b m
+            case x of
+                Nothing -> return Nothing
+                Just b' -> do
+                    modifyLayout cl (SomeMessage UnDoLayout)
+                    return . Just $ switched state{
+                        base = b',
+                        currLayout = cf b' }