Add "Selective" layout modifier

Ignore-this: ded23208563ca8c8d411916d01351132

darcs-hash:20090929160207-a5338-8da17faae1182548259cb9d304533c6239673710.gz

3 files changed, 173 insertions, 0 deletions

diff --git a/XMonad/Layout/Selective.hs b/XMonad/Layout/Selective.hs
new file mode 100644
index 0000000..415a69f
--- /dev/null
+++ b/XMonad/Layout/Selective.hs
@@ -0,0 +1,98 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.Selective
+-- Copyright   :  (c) 2009 Max Rabkin
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  Max Rabkin <max.rabkin@gmail.com>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Provides a layout modifier that only shows the master pane and windows
+-- around the focussed window.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE MultiParamTypeClasses,
+             FlexibleInstances,
+             NoMonomorphismRestriction,
+             NamedFieldPuns #-}
+
+module XMonad.Layout.Selective where
+
+import XMonad.Core
+import XMonad.StackSet
+import XMonad.Layout.LayoutModifier
+import Control.Applicative ((<$>))
+
+-- invariant: 0 <= nMaster <= start; 0 <= nRest
+data Selection = Sel { nMaster :: Int, start :: Int, nRest :: Int }
+    deriving (Read, Show, Eq)
+
+select :: Selection -> Stack a -> Stack a
+select (Sel { nMaster, start, nRest }) stk
+    | lups < nMaster
+        = stk { down=take (nMaster - lups - 1) downs ++
+                    (take nRest . drop (start - lups - 1) $ downs) }
+    | otherwise
+        = stk { up=reverse (take nMaster ups ++ drop start ups),
+                down=take (nRest - (lups - start) - 1) downs }
+    where
+        downs = down stk
+        ups = reverse $ up stk
+        lups = length ups
+    
+{-
+select :: Selection -> Stack a -> (Selection, Stack a)
+select sel@(Sel { nMaster, start, nRest }) stk
+    | lups < nMaster   -- the focussed window is in the master pane
+        = let start' = start `min` (lups + ldown - nRest + 1)
+                             `max` nMaster
+            in (sel { start=start' }, 
+                stk { down=take (nMaster - lups - 1) downs ++
+                            (take nRest . drop (start' - lups - 1) $ downs) })
+    | otherwise
+        = let start' = start `min` lups
+                             `max` (lups - nRest + 1) 
+                             `min` (lups + ldown - nRest + 1)
+                             `max` nMaster
+            in (sel { start=start' },
+                stk { up=reverse (take nMaster ups ++ drop start' ups),
+                      down=take (nRest - (lups - start') - 1) downs })
+    where
+        downs = down stk
+        ups = reverse $ up stk
+        lups = length ups
+        ldown = length downs
+-}
+
+updateStart :: Selection -> Stack a -> Int
+updateStart (Sel { nMaster, start, nRest }) stk
+    | lups < nMaster   -- the focussed window is in the master pane
+        = start `min` (lups + ldown - nRest + 1) `max` nMaster
+    | otherwise
+        = start `min` lups 
+                `max` (lups - nRest + 1) 
+                `min` (lups + ldown - nRest + 1) 
+                `max` nMaster
+    where
+        lups = length $ up stk
+        ldown = length $ down stk
+
+update :: Selection -> Stack a -> Selection
+update sel stk = sel { start=updateStart sel stk }
+
+updateAndSelect :: Selection -> Stack a -> Stack a
+updateAndSelect sel stk = select (update sel stk) stk
+
+data Selective a = Selective Selection
+    deriving (Read, Show)
+
+instance LayoutModifier Selective a where
+    modifyLayout (Selective s) w r =
+        runLayout (w { stack = updateAndSelect s <$> stack w }) r
+
+    pureModifier (Selective sel) _ stk wins = (wins, Selective . update sel <$> stk)
+
+selective :: Int -> Int -> l a -> ModifiedLayout Selective l a
+selective m r = ModifiedLayout . Selective $ Sel { nMaster=m, start=m, nRest=r }
diff --git a/tests/test_Selective.hs b/tests/test_Selective.hs
new file mode 100644
index 0000000..ffdb971
--- /dev/null
+++ b/tests/test_Selective.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}
+
+import XMonad.Layout.Selective
+import XMonad.StackSet hiding (focusUp, focusDown)
+import Control.Applicative ((<$>))
+import Test.QuickCheck
+import Control.Arrow (second)
+
+instance Arbitrary (Stack Int) where
+    arbitrary = do
+                    xs <- arbNat
+                    ys <- arbNat
+                    return $ Stack { up=[xs-1,xs-2..0], focus=xs, down=[xs+1..xs+ys] }
+    coarbitrary = undefined
+
+instance Arbitrary Selection where
+    arbitrary = do
+                    nm <- arbNat
+                    st <- arbNat
+                    nr <- arbPos
+                    return $ Sel nm (st+nm) nr
+    coarbitrary = undefined
+
+arbNat = abs <$> arbitrary
+arbPos = (+1) . abs <$> arbitrary
+
+-- as many windows as possible should be selected 
+-- (when the selection is normalized)
+prop_select_length sel (stk :: Stack Int) =
+    (length . integrate $ select sel' stk) == ((nMaster sel' + nRest sel') `min` length (integrate stk))
+    where
+        sel' = updateSel sel stk
+
+-- update normalizes selections (is idempotent)
+prop_update_idem sel (stk :: Stack Int) = sel' == updateSel sel' stk
+    where
+        sel' = updateSel sel stk
+
+-- select selects the master pane
+prop_select_master sel (stk :: Stack Int) = 
+    take (nMaster sel) (integrate stk) == take (nMaster sel) (integrate $ select sel stk)
+
+-- the focus should always be selected in normalized selections
+prop_select_focus sel (stk :: Stack Int) = focus stk == (focus $ select sel' stk)
+    where
+        sel' = updateSel sel stk
+
+-- select doesn't change order (or duplicate elements)
+-- relies on the Arbitrary instance for Stack Int generating increasing stacks
+prop_select_increasing sel (stk :: Stack Int) =
+    let res = integrate $ select sel stk
+     in and . zipWith (<) res $ tail res
+
+-- moving the focus to a window that's already selected doesn't change the selection
+prop_update_focus_up sel (stk :: Stack Int) x' =
+    (length (up stk) >= x) && ((up stk !! (x-1)) `elem` integrate stk') ==> 
+        sel' == updateSel sel' (iterate focusUp stk !! x)
+    where
+        x = 1 + abs x'
+        sel' = updateSel sel stk
+        stk' = select sel' stk
+
+prop_update_focus_down sel (stk :: Stack Int) x' =
+    (length (down stk) >= x) && ((down stk !! (x-1)) `elem` integrate stk') ==> 
+        sel' == updateSel sel' (iterate focusDown stk !! x)
+    where
+        x = 1 + abs x'
+        sel' = updateSel sel stk
+        stk' = select sel' stk
+
+upSel sel stk = let sel' = updateSel sel stk in (sel', select sel' stk)
+
+focusUp stk = stk { up=tail (up stk), focus=head (up stk), down=focus stk:down stk }
+focusDown stk = stk { down=tail (down stk), focus=head (down stk), up=focus stk:up stk }
diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal
index e589eeb..e425de0 100644
--- a/xmonad-contrib.cabal
+++ b/xmonad-contrib.cabal
@@ -183,6 +183,7 @@ library
                         XMonad.Layout.ResizableTile
                         XMonad.Layout.ResizeScreen
                         XMonad.Layout.Roledex
+                        XMonad.Layout.Selective
                         XMonad.Layout.Simplest
                         XMonad.Layout.SimpleDecoration
                         XMonad.Layout.SimpleFloat