Spiral.hs: add 'description' function to LayoutClass instance for SpiralWithDir.

I saw some complaints about ShellPrompt being slow - and noticed it myself - and it seems ShellPrompt uses 'nub' in an awkward place to uniquefy input. Nub doesn't perform well on long lists, but I once ran into a similar problem and the suggested solution was something clever: convert to a Set and then back to a List. Sets can't have duplicate entries, and they uniquefy faster than nub. The price is that the output is not sorted the same as nub's output would be, but this is OK because the output of (toList . fromList) is immediately passed to 'sort' - which should then produce the same output for both versions. I haven't really tested this but on long directories this should help.

Accordion.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.Accordion
@@ -8,42 +10,41 @@
 -- Stability   :  unstable
 -- Portability :  unportable
 --
--- Layout that puts non-focused windows in ribbons at the top and bottom
+-- LayoutClass that puts non-focused windows in ribbons at the top and bottom
 -- of the screen.
 -----------------------------------------------------------------------------
 
 module XMonadContrib.Accordion (
     -- * Usage
     -- $usage
-    accordion) where
+    Accordion(Accordion)) where
 
 import XMonad
 import Operations
 import qualified StackSet as W
 import Graphics.X11.Xlib
 import Data.Ratio
-import XMonadContrib.LayoutHelpers ( idModify )
 
 -- $usage
 -- > import XMonadContrib.Accordion
--- > defaultLayouts = [ accordion ]
+-- > layouts = [ Layout Accordion ]
 
-accordion :: Eq a => Layout a
-accordion = Layout { doLayout = accordionLayout, modifyLayout = idModify }
+-- %import XMonadContrib.Accordion
+-- %layout , Layout Accordion
 
-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
+data Accordion a = Accordion deriving ( Read, Show )
+
+instance LayoutClass Accordion Window where
+    pureLayout _ sc ws = zip ups tops ++ [(W.focus ws, mainPane)] ++ zip dns bottoms
+     where
+       ups    = W.up ws
        dns    = W.down ws
-       (top, allButTop) = splitVerticallyBy (1%8) sc
-       (center, bottom) = splitVerticallyBy (6%7) allButTop
-       (allButBottom, _) = splitVerticallyBy (7%8) sc
+       (top,  allButTop) = splitVerticallyBy (1%8 :: Ratio Int) sc
+       (center,  bottom) = splitVerticallyBy (6%7 :: Ratio Int) allButTop
+       (allButBottom, _) = splitVerticallyBy (7%8 :: Ratio Int) sc
        mainPane | ups /= [] && dns /= [] = center
                 | ups /= []              = allButTop
                 | dns /= []              = allButBottom
                 | otherwise              = sc
-       tops   = if ups /= [] then splitVertically (length ups) top else []
-       bottoms= if dns /= [] then splitVertically (length dns) bottom else []
+       tops    = if ups /= [] then splitVertically (length ups) top    else []
+       bottoms = if dns /= [] then splitVertically (length dns) bottom else []

Anneal.hs

@@ -8,6 +8,7 @@
 -- Stability   :  unstable
 -- Portability :  unportable
 --
+-- Requires the 'random' package
 --
 -----------------------------------------------------------------------------
 
@@ -17,6 +18,8 @@ module XMonadContrib.Anneal ( Rated(Rated), the_value, the_rating
 import System.Random ( StdGen, Random, mkStdGen, randomR )
 import Control.Monad.State ( State, runState, put, get, gets, modify )
 
+-- %import XMonadContrib.Anneal
+
 data Rated a b = Rated !a !b
                  deriving ( Show )
 instance Functor (Rated a) where

Circle.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.Circle
@@ -15,7 +17,7 @@
 module XMonadContrib.Circle (
                              -- * Usage
                              -- $usage
-                             circle
+                             Circle (..)
                             ) where -- actually it's an ellipse
 
 import Data.List
@@ -23,17 +25,19 @@ import Graphics.X11.Xlib
 import XMonad
 import StackSet (integrate, peek)
 
-import XMonadContrib.LayoutHelpers ( idModify )
-
 -- $usage
 -- You can use this module with the following in your Config.hs file:
 --
 -- > import XMonadContrib.Circle
+-- > layouts = [ Layout Circle ]
 
-circle :: Layout Window
-circle = Layout { doLayout = \r s -> do { layout <- raiseFocus $ circleLayout r $ integrate s
-                                       ;  return (layout, Nothing) }
-                , modifyLayout = idModify }
+-- %import XMonadContrib.Circle
+
+data Circle a = Circle deriving ( Read, Show )
+
+instance LayoutClass Circle Window where
+    doLayout Circle r s = do layout <- raiseFocus $ circleLayout r $ integrate s
+                             return (layout, Nothing)
 
 circleLayout :: Rectangle -> [a] -> [(a, Rectangle)]
 circleLayout _ []     = []

Combo.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.Combo
@@ -19,56 +21,76 @@ module XMonadContrib.Combo (
                            ) where
 
 import Control.Arrow ( first )
+import Data.List ( delete )
 import Data.Maybe ( isJust )
 import XMonad
-import StackSet ( integrate, differentiate )
+import StackSet ( integrate, Stack(..) )
+import qualified StackSet as W ( differentiate )
 
 -- $usage
 --
 -- To use this layout write, in your Config.hs:
 -- 
 -- > import XMonadContrib.Combo 
--- > import XMonadContrib.SimpleStacking
 -- 
 -- and add something like
 -- 
--- > simpleStacking $ combo (twoPane 0.03 0.5) [(full,1),(tabbed shrinkText,1)]
+-- > combo (TwoPane 0.03 0.5) [(Full,1),(tabbed shrinkText defaultTConf,1)]
 --
--- to your defaultLayouts.
+-- to your layouts.
 --
--- The first argument to combo is a Layout that will divide the screen into
+-- The first argument to combo is a layout that will divide the screen into
 -- one or more subscreens.  The second argument is a list of layouts which
--- will be used to lay out the contents of each of those subscreents.
+-- will be used to lay out the contents of each of those subscreens.
 -- Paired with each of these layouts is an integer giving the number of
 -- windows this section should hold.  This number is ignored for the last
 -- layout, which will hold any excess windows.
 
-combo :: Layout (Layout a, Int) -> [(Layout a, Int)] -> Layout a
-combo super origls = Layout { doLayout = \r s -> arrange r (integrate s), modifyLayout = message }
-    where arrange _ [] = return ([], Nothing)
-          arrange r [w] = return ([(w,r)], Nothing)
-          arrange rinput origws =
-              do (lrs, msuper') <- runLayout super rinput (differentiate $ take (length origws) origls)
-                 let super' = maybe super id msuper'
-                     lwrs [] _ = []
-                     lwrs [((l,_),r)] ws = [((l,r),differentiate ws)]
-                     lwrs (((l,n),r):xs) ws = ((l,r),differentiate $ take len1 ws) : lwrs xs (drop len1 ws)
-                         where len1 = min n (length ws - length xs)
-                 out <- mapM (uncurry $ uncurry runLayout) $ lwrs lrs origws
-                 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 super' origls')
-          message m = do mls <- broadcastPrivate m (map fst origls)
+-- %import XMonadContrib.Combo
+-- %layout , combo (twoPane 0.03 0.5) [(full,1),(tabbed shrinkText defaultTConf,1)]
+
+combo :: (Eq a, Show a, Read a, ReadableLayout a, LayoutClass l (Layout a, Int))
+         => (l (Layout a, Int)) -> [(Layout a, Int)] -> Combo l a
+combo = Combo []
+
+data Combo l a = Combo [a] (l (Layout a, Int)) [(Layout a, Int)]
+                 deriving (Show, Read)
+
+instance (Eq a, Show a, Read a, ReadableLayout a, LayoutClass l (Layout a, Int))
+    => LayoutClass (Combo l) a where
+    doLayout (Combo f super origls) rinput s = arrange (integrate s)
+        where arrange [] = return ([], Just $ Combo [] super origls)
+              arrange [w] = return ([(w,rinput)], Just $ Combo [w] super origls)
+              arrange origws =
+                do (lrs, msuper') <- runLayout super rinput (W.differentiate $ take (length origws) origls)
+                   let super' = maybe super id msuper'
+                       f' = focus s:delete (focus s) f
+                       lwrs [] _ = []
+                       lwrs [((l,_),r)] ws = [((l,r),differentiate f' ws)]
+                       lwrs (((l,n),r):xs) ws = ((l,r),differentiate f' $ take len1 ws) : lwrs xs (drop len1 ws)
+                           where len1 = min n (length ws - length xs)
+                   out <- mapM (uncurry $ uncurry runLayout) $ lwrs lrs origws
+                   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 f' super' origls')
+              differentiate :: Eq q => [q] -> [q] -> Maybe (Stack q)
+              differentiate (z:zs) xs | z `elem` xs = Just $ Stack { focus=z
+                                                                   , up = reverse $ takeWhile (/=z) xs
+                                                                   , down = tail $ dropWhile (/=z) xs }
+                                      | otherwise = differentiate zs xs
+              differentiate [] xs = W.differentiate xs
+    handleMessage (Combo f super origls) m =
+                      do mls <- broadcastPrivate m (map fst origls)
                          let mls' = (\x->zipWith first (map const x) origls) `fmap` mls
                          msuper <- broadcastPrivate m [super]
                          case msuper of
-                           Just [super'] -> return $ Just $ combo super' $ maybe origls id mls'
-                           _ -> return $ combo super `fmap` mls'
+                           Just [super'] -> return $ Just $ Combo f super' $ maybe origls id mls'
+                           _ -> return $ Combo f super `fmap` mls'
 
-broadcastPrivate :: SomeMessage -> [Layout b] -> X (Maybe [Layout b])
+broadcastPrivate :: LayoutClass l b => SomeMessage -> [l b] -> X (Maybe [l 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
+    where f l = handleMessage l a `catchX` return Nothing

Commands.hs

@@ -27,8 +27,9 @@ module XMonadContrib.Commands (
 
 import XMonad
 import Operations
+import StackSet hiding (workspaces)
 import XMonadContrib.Dmenu (dmenu)
-import {-# SOURCE #-} Config (workspaces)
+import {-# SOURCE #-} Config (workspaces,serialisedLayouts)
 
 import qualified Data.Map as M
 import System.Exit
@@ -42,7 +43,7 @@ import Data.Maybe
 --
 -- and add a keybinding to the runCommand action:
 --
--- >    , ((modMask .|. controlMask, xK_y), runCommand)
+-- >    , ((modMask .|. controlMask, xK_y), runCommand commands)
 --
 -- and define the list commands:
 --
@@ -54,40 +55,48 @@ import Data.Maybe
 -- 'commands'.  (If you like it enough, you may even want to get rid
 -- of many of your other key bindings!)
 
+-- %def commands :: [(String, X ())]
+-- %def commands = defaultCommands
+-- %import XMonadContrib.Commands
+-- %keybind , ((modMask .|. controlMask, xK_y), runCommand commands)
+
 commandMap :: [(String, X ())] -> M.Map String (X ())
 commandMap c = M.fromList c
 
 workspaceCommands :: [(String, X ())]
-workspaceCommands = [((m ++ show i), f i)
+workspaceCommands = [((m ++ show i), windows $ f i)
                          | i <- workspaces
                          , (f, m) <- [(view, "view"), (shift, "shift")]
                     ]
 
 screenCommands :: [(String, X ())]
-screenCommands = [((m ++ show sc), screenWorkspace (fromIntegral sc) >>= flip whenJust f)
+screenCommands = [((m ++ show sc), screenWorkspace (fromIntegral sc) >>= flip whenJust (windows . f))
                       | sc <- [0, 1]::[Int] -- TODO: adapt to screen changes
                       , (f, m) <- [(view, "screen"), (shift, "screen-to-")]
                  ]
 
 defaultCommands :: [(String, X ())]
 defaultCommands = workspaceCommands ++ screenCommands
-                  ++ [ ("shrink", sendMessage Shrink)
-                     , ("expand", sendMessage Expand)
-                     , ("restart-wm", restart Nothing True)
-                     , ("restart-wm-no-resume", restart Nothing False)
-                     , ("layout", switchLayout)
-                     , ("xterm", spawn "xterm")
-                     , ("run", spawn "exe=`dmenu_path | dmenu -b` && exec $exe")
-                     , ("kill", kill)
-                     , ("refresh", refresh)
-                     , ("focus-up", focusUp)
-                     , ("focus-down", focusDown)
-                     , ("swap-up", swapUp)
-                     , ("swap-down", swapDown)
-                     , ("swap-master", swapMaster)
-                     , ("sink", withFocused sink)
-                     , ("quit-wm", io $ exitWith ExitSuccess)
+                  ++ [ ("shrink"              , sendMessage Shrink                               )
+                     , ("expand"              , sendMessage Expand                               )
+                     , ("next-layout"         , sendMessage NextLayout                           )
+                     , ("previous-layout"     , sendMessage PrevLayout                           )
+                     , ("default-layout"      , setLayout (head serialisedLayouts)                 )
+                     , ("restart-wm"          , sr >> restart Nothing True                       )
+                     , ("restart-wm-no-resume", sr >> restart Nothing False                      )
+                     , ("xterm"               , spawn "xterm"                                    )
+                     , ("run"                 , spawn "exe=`dmenu_path | dmenu -b` && exec $exe" )
+                     , ("kill"                , kill                                             )
+                     , ("refresh"             , refresh                                          )
+                     , ("focus-up"            , windows $ focusUp                                )
+                     , ("focus-down"          , windows $ focusDown                              )
+                     , ("swap-up"             , windows $ swapUp                                 )
+                     , ("swap-down"           , windows $ swapDown                               )
+                     , ("swap-master"         , windows $ swapMaster                             )
+                     , ("sink"                , withFocused $ windows . sink                     )
+                     , ("quit-wm"             , io $ exitWith ExitSuccess                        )
                      ]
+    where sr = broadcastMessage ReleaseResources
 
 runCommand :: [(String, X ())] -> X ()
 runCommand cl = do

CopyWindow.hs

@@ -43,37 +43,26 @@ import StackSet
 --
 -- >  , ((modMask .|. shiftMask, xK_c     ), kill1) -- @@ Close the focused window
 
+-- %import XMonadContrib.CopyWindow
+-- %keybind -- comment out default close window binding above if you uncomment this:
+-- %keybind , ((modMask .|. shiftMask, xK_c     ), kill1) -- @@ Close the focused window
+-- %keybindlist ++
+-- %keybindlist -- mod-[1..9] @@ Switch to workspace N
+-- %keybindlist -- mod-shift-[1..9] @@ Move client to workspace N
+-- %keybindlist -- mod-control-shift-[1..9] @@ Copy client to workspace N
+-- %keybindlist [((m .|. modMask, k), f i)
+-- %keybindlist     | (i, k) <- zip workspaces [xK_1 ..]
+-- %keybindlist     , (f, m) <- [(view, 0), (shift, shiftMask), (copy, shiftMask .|. controlMask)]]
+
 -- | copy. Copy a window to a new workspace.
-copy :: WorkspaceId -> X ()
-copy n = windows (copy' n)
-
-copy' :: (Ord a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd
-copy' n s = if n `tagMember` s && n /= tag (workspace (current s))
-            then maybe s go (peek s)
-            else s
-    where go w = view (tag (workspace (current s))) $ insertUp' w $ view n s
-
- 
--- |
--- /O(n)/. (Complexity due to check if element is in current stack.) Insert
--- a new element into the stack, above the currently focused element.
---
--- The new element is given focus, and is set as the master window.
--- The previously focused element is moved down.  The previously
--- 'master' element is forgotten. (Thus, 'insert' will cause a retiling).
---
--- If the element is already in the current stack, it is shifted to the
--- focus position, as if it had been removed and then added.
---
--- Semantics in Huet's paper is that insert doesn't move the cursor.
--- However, we choose to insert above, and move the focus.
-
-insertUp' :: Eq a => a -> StackSet i a s sd -> StackSet i a s sd
-insertUp' a s = modify (Just $ Stack a [] [])
-                (\(Stack t l r) -> Just $ Stack a (L.delete a l) (L.delete a (t:r))) s
-
-delete' :: Ord a => a -> StackSet i a s sd -> StackSet i a s sd
-delete' w = sink w . modify Nothing (filter (/= w))
+copy :: WorkspaceId -> WindowSet -> WindowSet
+copy n = copy'
+    where copy' s = if n `tagMember` s && n /= tag (workspace (current s))
+                    then maybe s (go s) (peek s)
+                    else s
+          go s w = view (tag (workspace (current s))) $ insertUp' w $ view n s
+          insertUp' a s = modify (Just $ Stack a [] [])
+                          (\(Stack t l r) -> Just $ Stack a (L.delete a l) (L.delete a (t:r))) s
 
 -- | Remove the focussed window from this workspace.  If it's present in no
 -- other workspace, then kill it instead. If we do kill it, we'll get a
@@ -84,6 +73,7 @@ delete' w = sink w . modify Nothing (filter (/= w))
 --
 kill1 :: X ()
 kill1 = do ss <- gets windowset
-           whenJust (peek ss) $ \w -> if member w $ delete' w ss
-                                      then windows $ delete' w
+           whenJust (peek ss) $ \w -> if member w $ delete'' w ss
+                                      then windows $ delete'' w
                                       else kill
+    where delete'' w = modify Nothing (filter (/= w))

CycleWS.hs

@@ -0,0 +1,99 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.CycleWS
+-- Copyright   :  (c) Joachim Breitner <mail@joachim-breitner.de>
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Provides bindings to cycle forward or backward through the list
+-- of workspaces, and to move windows there.
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.CycleWS (
+                              -- * Usage
+                              -- $usage
+                              nextWS,
+                              prevWS,
+			      shiftToNext,
+			      shiftToPrev,
+                             ) where
+
+import Control.Monad.State ( gets )
+import Data.List ( sortBy, findIndex )
+import Data.Maybe ( fromMaybe )
+import Data.Ord ( comparing )
+
+import XMonad
+import StackSet hiding (filter, findIndex)
+import Operations
+import {-# SOURCE #-} qualified Config (workspaces)
+
+-- $usage
+-- You can use this module with the following in your Config.hs file:
+-- 
+-- > import XMonadContrib.CycleWS
+--
+-- >   , ((modMask,               xK_Right), nextWS)
+-- >   , ((modMask,               xK_Left),  prevWS)
+-- >   , ((modMask .|. shiftMask, xK_Right), shiftToNext)
+-- >   , ((modMask .|. shiftMask, xK_Left),  shiftToPrev)
+--
+-- If you want to follow the moved window, you can use both actions:
+--
+-- >   , ((modMask .|. shiftMask, xK_Right), shiftToNext >> nextWS)
+-- >   , ((modMask .|. shiftMask, xK_Left),  shiftToPrev >> prevWS)
+--
+
+-- %import XMonadContrib.CycleWS
+-- %keybind , ((modMask,               xK_Right), nextWS)
+-- %keybind , ((modMask,               xK_Left),  prevWS)
+-- %keybind , ((modMask .|. shiftMask, xK_Right), shiftToNext)
+-- %keybind , ((modMask .|. shiftMask, xK_Left),  shiftToPrev)
+
+
+-- ---------------------
+-- |
+-- Switch to next workspace
+nextWS :: X()
+nextWS = switchWorkspace (1)
+
+-- ---------------------
+-- |
+-- Switch to previous workspace
+prevWS :: X()
+prevWS = switchWorkspace (-1)
+
+-- |
+-- Move focused window to next workspace
+shiftToNext :: X()
+shiftToNext = shiftBy (1)
+
+-- |
+-- Move focused window to previous workspace
+shiftToPrev :: X ()
+shiftToPrev = shiftBy (-1)
+
+switchWorkspace :: Int -> X ()
+switchWorkspace d = wsBy d >>= windows . greedyView
+
+shiftBy :: Int -> X ()
+shiftBy d = wsBy d >>= windows . shift
+
+wsBy :: Int -> X (WorkspaceId)
+wsBy d = do
+    ws <- gets windowset
+    let orderedWs = sortBy (comparing wsIndex) (workspaces ws)
+    let now = fromMaybe 0 $ findWsIndex (workspace (current ws)) orderedWs
+    let next = orderedWs !! ((now + d) `mod` length orderedWs)
+    return $ tag next
+
+
+wsIndex :: WindowSpace -> Maybe Int
+wsIndex ws = findIndex (==(tag ws)) Config.workspaces
+
+findWsIndex :: WindowSpace -> [WindowSpace] -> Maybe Int
+findWsIndex ws wss = findIndex ((== tag ws) . tag) wss

DeManage.hs

@@ -1,4 +1,3 @@
-{-# OPTIONS -fglasgow-exts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.DeManage
@@ -48,6 +47,9 @@ import Graphics.X11 (Window)
 -- > , ((modMask,               xK_d     ), withFocused demanage)
 --
 
+-- %import XMonadContrib.DeManage
+-- %keybind , ((modMask,               xK_d     ), withFocused demanage)
+
 -- | Stop managing the current focused window.
 demanage :: Window -> X ()
 demanage w = do

Decoration.hs

@@ -1,74 +0,0 @@
-{-# OPTIONS -fglasgow-exts #-}
------------------------------------------------------------------------------
--- |
--- Module      :  XMonadContrib.Decoration
--- Copyright   :  (c) David Roundy <droundy@darcs.net>
--- License     :  BSD-style (see LICENSE)
--- 
--- Maintainer  :  David Roundy <droundy@darcs.net>
--- Stability   :  unstable
--- Portability :  unportable
---
--- A module to be used to easily define decorations.
---
------------------------------------------------------------------------------
-
-module XMonadContrib.Decoration (
-                                 -- * Usage
-                                 -- $usage 
-                                 newDecoration 
-                                ) where
-
-import Data.Bits ( (.|.) )
-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.LayoutHelpers ( ModLay, layoutModify, idModDo )
-
-import XMonad
-import Operations ( UnDoLayout(UnDoLayout) )
-
--- $usage
--- 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 () -> Layout a -> X (Layout a)
-newDecoration decfor (Rectangle x y w h) th fg bg fn draw click l = 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
-    io $ restackWindows d $ decfor : [win]
-
-    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
-        handle_event (ButtonEvent {ev_window = thisw,ev_event_type = t})
-            | t == buttonPress && thisw == win        = click
-        handle_event (AnyEvent {ev_window = thisw, ev_event_type = t})
-            | thisw == win    && t == expose          = withGC win fn draw
-            | thisw == decfor && t == propertyNotify  = withGC win fn draw
-        handle_event _ = return ()
-
-    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 ()
-withGC w fn f = withDisplay $ \d -> do gc <- io $ createGC d w
-                                       let fontname = if fn == "" 
-                                                      then "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-                                                      else fn
-                                       font <- io $ catch (loadQueryFont d fontname)
-                                                          (const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*")
-                                       io $ setFont d gc (fontFromFontStruct font)
-                                       f d w gc font
-                                       io $ freeGC d gc
-                                       io $ freeFont d font

DirectoryPrompt.hs

@@ -37,6 +37,7 @@ getDirCompl :: String -> IO [String]
 getDirCompl s = (filter notboring . lines) `fmap`
                 runProcessWithInput "/bin/bash" [] ("compgen -A directory " ++ s ++ "\n")
 
+notboring :: String -> Bool
 notboring ('.':'.':_) = True
 notboring ('.':_) = False
 notboring _ = True

Dishes.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.Dishes
+-- Copyright   :  (c) Jeremy Apthorp
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Jeremy Apthorp <nornagon@gmail.com>
+-- Stability   :  unstable
+-- Portability :  portable
+--
+-- Dishes is a layout that stacks extra windows underneath the master
+-- windows.
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.Dishes (
+                              -- * Usage
+															-- $usage
+                              Dishes (..)
+                            ) where
+
+import Data.List
+import XMonad
+import Operations
+import StackSet (integrate)
+import Control.Monad (ap)
+import Graphics.X11.Xlib
+
+-- $usage
+-- You can use this module with the following in your Config.hs file:
+--
+-- > import XMonadContrib.Dishes
+--
+-- and add the following line to your 'layouts'
+--
+-- > , Layout $ Dishes 2 (1%6)
+
+-- %import XMonadContrib.Dishes
+-- %layout , Layout $ Dishes 2 (1%6)
+
+data Dishes a = Dishes Int Rational deriving (Show, Read)
+instance LayoutClass Dishes a where
+	doLayout (Dishes nmaster h) r =
+		return . (\x->(x,Nothing)) .
+		ap zip (dishes h r nmaster . length) . integrate
+	pureMessage (Dishes nmaster h) m = fmap incmastern (fromMessage m)
+		where incmastern (IncMasterN d) = Dishes (max 0 (nmaster+d)) h
+
+dishes :: Rational -> Rectangle -> Int -> Int -> [Rectangle]
+dishes h s nmaster n = if n <= nmaster
+		then splitHorizontally n s
+		else ws
+	where
+		(m,rest) = splitVerticallyBy (1 - (fromIntegral $ n - nmaster) * h) s
+		ws = splitHorizontally nmaster m ++ splitVertically (n - nmaster) rest

Dmenu.hs

@@ -3,24 +3,27 @@
 -- Module      :  XMonadContrib.Dmenu
 -- Copyright   :  (c) Spencer Janssen <sjanssen@cse.unl.edu>
 -- License     :  BSD-style (see LICENSE)
--- 
+--
 -- Maintainer  :  Spencer Janssen <sjanssen@cse.unl.edu>
 -- Stability   :  unstable
 -- Portability :  unportable
 --
 -- A convenient binding to dmenu.
 --
+-- Requires the process-1.0 package
+--
 -----------------------------------------------------------------------------
 
 module XMonadContrib.Dmenu (
                             -- * Usage
-                            -- $usage 
-                            dmenu, dmenuXinerama, 
+                            -- $usage
+                            dmenu, dmenuXinerama, dmenuMap,
                             runProcessWithInput
                            ) where
 
 import XMonad
 import qualified StackSet as W
+import qualified Data.Map as M
 import System.Process
 import System.IO
 import Control.Monad.State
@@ -30,6 +33,10 @@ import Control.Monad.State
 --
 -- > import XMonadContrib.Dmenu
 
+-- %import XMonadContrib.Dmenu
+
+-- | Returns Just output if the command succeeded, and Nothing if it didn't.
+-- This corresponds to dmenu's notion of exit code 1 for a cancelled invocation.
 runProcessWithInput :: FilePath -> [String] -> String -> IO String
 runProcessWithInput cmd args input = do
     (pin, pout, perr, ph) <- runInteractiveProcess cmd args Nothing Nothing
@@ -41,7 +48,7 @@ runProcessWithInput cmd args input = do
     hClose perr
     waitForProcess ph
     return output
-    
+
 -- | Starts dmenu on the current screen. Requires this patch to dmenu:
 -- <http://www.jcreigh.com/dmenu/dmenu-3.2-xinerama.patch>
 dmenuXinerama :: [String] -> X String
@@ -52,3 +59,7 @@ dmenuXinerama opts = do
 dmenu :: [String] -> X String
 dmenu opts = io $ runProcessWithInput "dmenu" [] (unlines opts)
 
+dmenuMap :: M.Map String a -> X (Maybe a)
+dmenuMap selectionMap = do
+  selection <- dmenu (M.keys selectionMap)
+  return $ M.lookup selection selectionMap

DragPane.hs

@@ -1,14 +1,19 @@
+{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.DragPane
 -- Copyright   :  (c) Spencer Janssen <sjanssen@cse.unl.edu>
 --                    David Roundy <droundy@darcs.net>,
+--                    Andrea Rossato <andrea.rossato@unibz.it>
 -- License     :  BSD3-style (see LICENSE)
 -- 
 -- Maintainer  :  David Roundy <droundy@darcs.net>
+--                Andrea Rossato <andrea.rossato@unibz.it>
 -- Stability   :  unstable
 -- Portability :  unportable
-
+--
 -- Layouts that splits the screen either horizontally or vertically and
 -- shows two windows.  The first window is always the master window, and
 -- the other is either the currently focused window or the second window in
@@ -19,15 +24,20 @@
 module XMonadContrib.DragPane (
                                -- * Usage
                                -- $usage
-                               dragPane, dragUpDownPane
+                                dragPane
+                              , DragType (..)
                               ) where
 
-import Control.Monad.Reader ( asks )
-import Graphics.X11.Xlib ( Rectangle( Rectangle ) )
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
 import XMonad
-import XMonadContrib.Decoration ( newDecoration )
-import Operations ( Resize(..), splitHorizontallyBy, splitVerticallyBy, initColor, mouseDrag, sendMessage )
-import StackSet ( focus, up, down)
+import Data.Bits
+import Data.Unique
+
+import Operations 
+import qualified StackSet as W 
+import XMonadContrib.Invisible
+import XMonadContrib.XUtils
 
 -- $usage
 --
@@ -37,83 +47,90 @@ import StackSet ( focus, up, down)
 --
 --  and add, to the list of layouts:
 --
--- > dragPane "" (fromRational delta) (fromRational delta)
+-- > Layout $ dragPane Horizontal 0.1 0.5
 
 halfHandleWidth :: Integral a => a
-halfHandleWidth = 2
+halfHandleWidth = 1
 
 handleColor :: String
 handleColor = "#000000"
 
-dragPane :: String -> Double -> Double -> Layout a
-dragPane ident delta split = Layout { doLayout = dolay, modifyLayout = return . message }
- where
-    dolay r s = do handlec <- withDisplay $ \dpy -> io $ initColor dpy handleColor
-                   root <- asks theRoot
-                   let (left', right') = splitHorizontallyBy split r
-                       leftmost = fromIntegral $ case r of Rectangle x _ _ _ -> x
-                       widt = fromIntegral $ case r of Rectangle _ _ w _ -> w
-                       left = case left' of Rectangle x y w h -> Rectangle x y (w-halfHandleWidth) h
-                       right = case right' of
-                               Rectangle x y w h -> Rectangle (x+halfHandleWidth) y (w-halfHandleWidth) h
-                       handr = case left' of
-                               Rectangle x y w h ->
-                                 Rectangle (x + fromIntegral w - halfHandleWidth) y (2*halfHandleWidth) h
-                       wrs = case reverse (up s) of
-                             (master:_) -> [(master,left),(focus s,right)]
-                             [] -> case down s of
-                                   (next:_) -> [(focus s,left),(next,right)]
-                                   [] -> [(focus s, r)]
-                       handle = newDecoration root handr 0 handlec handlec
-                                "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-                                (const $ const $ const $ const $ return ()) (doclick)
-                       doclick = mouseDrag (\ex _ ->
-                                        sendMessage (SetFrac ident ((fromIntegral ex - leftmost)/widt)))
-                                        (return ())
-                                        
-                   ml' <- if length wrs > 1 then Just `fmap` handle (dragPane ident delta split)
-                                            else return Nothing
-                   return (wrs, ml')
-    message x | Just Shrink <- fromMessage x = Just (dragPane ident delta (split - delta))
-              | Just Expand <- fromMessage x = Just (dragPane ident delta (split + delta))
-              | Just (SetFrac ident' frac) <- fromMessage x, ident' == ident =
-                                              Just (dragPane ident delta frac)
-    message _ = Nothing
+dragPane :: DragType -> Double -> Double -> DragPane a
+dragPane t x y = DragPane (I Nothing) t x y
 
-dragUpDownPane :: String -> Double -> Double -> Layout a
-dragUpDownPane ident delta split = Layout { doLayout = dolay, modifyLayout = return . message }
- where
-    dolay r s = do handlec <- withDisplay $ \dpy -> io $ initColor dpy handleColor
-                   root <- asks theRoot
-                   let (left', right') = splitVerticallyBy split r
-                       leftmost = fromIntegral $ case r of Rectangle _ x _ _ -> x
-                       widt = fromIntegral $ case r of Rectangle _ _ _ w -> w
-                       left = case left' of Rectangle x y w h -> Rectangle x y w (h-halfHandleWidth)
-                       right = case right' of
-                               Rectangle x y w h -> Rectangle x (y+halfHandleWidth) w (h-halfHandleWidth)
-                       handr = case left' of
-                               Rectangle x y w h ->
-                                 Rectangle x (y + fromIntegral h - halfHandleWidth) w (2*halfHandleWidth)
-                       wrs = case reverse (up s) of
-                             (master:_) -> [(master,left),(focus s,right)]
-                             [] -> case down s of
-                                   (next:_) -> [(focus s,left),(next,right)]
-                                   [] -> [(focus s, r)]
-                       handle = newDecoration root handr 0 handlec handlec
-                                "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-                                (const $ const $ const $ const $ return ()) (doclick)
-                       doclick = mouseDrag (\_ ey ->
-                                        sendMessage (SetFrac ident ((fromIntegral ey - leftmost)/widt)))
-                                        (return ())
-                                        
-                   ml' <- if length wrs > 1 then Just `fmap` handle (dragUpDownPane ident delta split)
-                                            else return Nothing
-                   return (wrs, ml')
-    message x | Just Shrink <- fromMessage x = Just (dragUpDownPane ident delta (split - delta))
-              | Just Expand <- fromMessage x = Just (dragUpDownPane ident delta (split + delta))
-              | Just (SetFrac ident' frac) <- fromMessage x, ident' == ident =
-                                              Just (dragUpDownPane ident delta frac)
-    message _ = Nothing
+data DragPane a = 
+    DragPane (Invisible Maybe (Window,Rectangle,Int)) DragType Double Double 
+             deriving ( Show, Read )
 
-data SetFrac = SetFrac String Double deriving ( Show, Read, Eq, Typeable )
+data DragType = Horizontal | Vertical deriving ( Show, Read )
+
+instance LayoutClass DragPane Window where
+    doLayout d@(DragPane _ Vertical   _ _) = doLay id d
+    doLayout d@(DragPane _ Horizontal _ _) = doLay mirrorRect d
+    handleMessage = handleMess
+
+data SetFrac = SetFrac Int Double deriving ( Show, Read, Eq, Typeable )
 instance Message SetFrac
+
+handleMess :: DragPane Window -> SomeMessage -> X (Maybe (DragPane Window)) 
+handleMess d@(DragPane mb@(I (Just (win,_,ident))) ty delta split) x
+    | Just e <- fromMessage x :: Maybe Event = do handleEvent d e
+                                                  return Nothing
+    | Just Hide             <- fromMessage x = do hideWindow win
+                                                  return $ Just (DragPane mb ty delta split)
+    | Just ReleaseResources <- fromMessage x = do deleteWindow win
+                                                  return $ Just (DragPane (I Nothing) ty delta split)
+    -- layout specific messages
+    | Just Shrink <- fromMessage x = return $ Just (DragPane mb ty delta (split - delta))
+    | Just Expand <- fromMessage x = return $ Just (DragPane mb ty delta (split + delta))
+    | Just (SetFrac ident' frac) <- fromMessage x, ident' == ident = do
+                                     return $ Just (DragPane mb ty delta frac)
+handleMess _ _ = return Nothing
+
+handleEvent :: DragPane Window -> Event -> X ()
+handleEvent (DragPane (I (Just (win,r,ident))) ty _ _) 
+            (ButtonEvent {ev_window = thisw, ev_subwindow = thisbw, ev_event_type = t })
+    | t == buttonPress && thisw == win || thisbw == win  = do
+  mouseDrag (\ex ey -> do
+             let frac = case ty of
+                          Vertical   -> (fromIntegral ex - (fromIntegral $ rect_x r))/(fromIntegral $ rect_width  r)
+                          Horizontal -> (fromIntegral ey - (fromIntegral $ rect_y r))/(fromIntegral $ rect_height r)
+             sendMessage (SetFrac ident frac))
+            (return ())
+handleEvent _ _  = return ()
+
+doLay :: (Rectangle -> Rectangle) -> DragPane Window -> Rectangle -> W.Stack a -> X ([(a, Rectangle)], Maybe (DragPane a))
+doLay mirror (DragPane mw ty delta split) r s = do
+  let r' = mirror r
+      (left', right') = splitHorizontallyBy split r'
+      left = case left' of Rectangle x y w h ->
+                               mirror $ Rectangle x y (w-halfHandleWidth) h
+      right = case right' of
+                Rectangle x y w h ->
+		    mirror $ Rectangle (x+halfHandleWidth) y (w-halfHandleWidth) h
+      handr = case left' of
+                Rectangle x y w h ->
+                    mirror $ Rectangle (x + fromIntegral w - halfHandleWidth) y (2*halfHandleWidth) h
+      wrs = case reverse (W.up s) of
+              (master:_) -> [(master,left),(W.focus s,right)]
+              [] -> case W.down s of
+                      (next:_) -> [(W.focus s,left),(next,right)]
+                      [] -> [(W.focus s, r)]
+  if length wrs > 1 
+     then case mw of
+            I (Just (w,_,ident)) -> do 
+                    w' <- deleteWindow w >> newDragWin handr
+                    return (wrs, Just $ DragPane (I $ Just (w',r',ident)) ty delta split)
+            I Nothing -> do 
+                    w <- newDragWin handr
+                    i <- io $ newUnique
+                    return (wrs, Just $ DragPane (I $ Just (w,r',hashUnique i)) ty delta split)
+     else return (wrs, Nothing)
+
+
+newDragWin :: Rectangle -> X Window
+newDragWin r = do
+  let mask = Just $ exposureMask .|. buttonPressMask
+  w <- createNewWindow r mask handleColor
+  showWindow  w
+  return      w

DwmPromote.hs

@@ -36,11 +36,12 @@ import StackSet
 --
 -- >   , ((modMask,               xK_Return), dwmpromote)
 
-dwmpromote :: X ()
-dwmpromote = windows swap
+-- %import XMonadContrib.DwmPromote
+-- %keybind , ((modMask,               xK_Return), dwmpromote)
 
-swap :: StackSet i a s sd -> StackSet i a s sd
-swap = modify' $ \c -> case c of
-    Stack _ [] []     -> c
-    Stack t [] (x:rs) -> Stack x [] (t:rs)
-    Stack t ls rs     -> Stack t [] (ys ++ x : rs) where (x:ys) = reverse ls
+dwmpromote :: X ()
+dwmpromote = windows $ modify' $
+             \c -> case c of
+                   Stack _ [] []     -> c
+                   Stack t [] (x:rs) -> Stack x [] (t:rs)
+                   Stack t ls rs     -> Stack t [] (ys ++ x : rs) where (x:ys) = reverse ls

DynamicLog.hs

@@ -14,24 +14,35 @@
 --
 -- >     1 2 [3] 4 8
 --
--- format. suitable to pipe into dzen.
+-- format. Suitable to pipe into dzen.
 --
 -----------------------------------------------------------------------------
 
 module XMonadContrib.DynamicLog (
     -- * Usage
     -- $usage 
-    dynamicLog, dynamicLogXinerama, pprWindowSet, pprWindowSetXinerama
+    dynamicLog,
+    dynamicLogWithTitle,
+    dynamicLogWithTitleColored,
+    dynamicLogXinerama,
+
+    pprWindowSet,
+    pprWindowSetXinerama
   ) where
 
 -- 
 -- Useful imports
 --
 import XMonad
+import {-# SOURCE #-} Config (workspaces)
+import Operations () -- for ReadableSomeLayout instance
 import Data.Maybe ( isJust )
 import Data.List
 import Data.Ord ( comparing )
 import qualified StackSet as S
+import Data.Monoid
+import XMonadContrib.NamedWindows
+import Data.Char
 
 -- $usage 
 --
@@ -39,6 +50,23 @@ import qualified StackSet as S
 --
 -- >    import XMonadContrib.DynamicLog
 -- >    logHook = dynamicLog
+--
+-- To get the title of the currently focused window after the workspace list:
+--
+-- >    import XMonadContrib.DynamicLog
+-- >    logHook = dynamicLogWithTitle
+--
+-- To have the window title highlighted in any color recognized by dzen:
+--
+-- >    import XMonadContrib.DynamicLog
+-- >    logHook = dynamicLogWithTitleColored "white"
+--
+
+-- %import XMonadContrib.DynamicLog
+-- %def -- comment out default logHook definition above if you uncomment any of these:
+-- %def logHook = dynamicLog
+-- %def logHook = dynamicLogWithTitle
+-- %def logHook = dynamicLogWithTitleColored "white"
 
 
 -- |
@@ -47,23 +75,70 @@ import qualified StackSet as S
 --      * do nothing
 --      * log the state to stdout
 --
--- An example logger, print a status bar output to dzen, in the form:
+-- | 
+-- An example log hook, print a status bar output to dzen, in the form:
 --
--- > 1 2 [3] 4 7
+-- > 1 2 [3] 4 7 : full
+--
+-- That is, the currently populated workspaces, and the current
+-- workspace layout
 --  
-
 dynamicLog :: X ()
-dynamicLog = withWindowSet $ io . putStrLn . pprWindowSet
+dynamicLog = withWindowSet $ \ws -> do
+    let ld = description . S.layout . S.workspace . S.current $ ws
+        wn = pprWindowSet ws
+    io . putStrLn $ concat [wn ," : " ,map toLower ld]
+
+-- | Appends title of currently focused window to log output, and the
+-- current layout mode, to the normal dynamic log format.
+-- Arguments are: pre-title text and post-title text
+--
+-- The result is rendered in the form:
+--
+-- > 1 2 [3] 4 7 : full : urxvt
+--
+dynamicLogWithTitle_ :: String -> String -> X ()
+dynamicLogWithTitle_ pre post= do
+    -- layout description
+    ld <- withWindowSet $ return . description . S.layout . S.workspace . S.current
+    -- workspace list
+    ws <- withWindowSet $ return . pprWindowSet
+    -- window title
+    wt <- withWindowSet $ maybe (return "") (fmap show . getName) . S.peek
+
+    io . putStrLn $ concat [ws ," : " ,map toLower ld
+                           , case wt of
+                                   [] -> []
+                                   s  -> " : " ++ pre ++ s ++ post
+                           ]
+
+dynamicLogWithTitle :: X ()
+dynamicLogWithTitle = dynamicLogWithTitle_ "" ""
+
+-- | 
+-- As for dynamicLogWithTitle but with colored window title (for dzen use)
+--
+dynamicLogWithTitleColored :: String -> X ()
+dynamicLogWithTitleColored color = dynamicLogWithTitle_ ("^fg(" ++ color ++ ")") "^fg()"
 
 pprWindowSet :: WindowSet -> String
-pprWindowSet s =  concatMap fmt $ sortBy (comparing S.tag)
+pprWindowSet s =  concatMap fmt $ sortBy cmp
             (map S.workspace (S.current s : S.visible s) ++ S.hidden s)
-   where this     = S.tag (S.workspace (S.current s))
+   where f Nothing Nothing   = EQ
+         f (Just _) Nothing  = LT
+         f Nothing (Just _)  = GT
+         f (Just x) (Just y) = compare x y
+
+         wsIndex = flip elemIndex workspaces . S.tag
+
+         cmp a b = f (wsIndex a) (wsIndex b) `mappend` compare (S.tag a) (S.tag b)
+
+         this     = S.tag (S.workspace (S.current s))
          visibles = map (S.tag . S.workspace) (S.visible s)
 
-         fmt w | S.tag w == this         = "[" ++ pprTag w ++ "]"
-               | S.tag w `elem` visibles = "<" ++ pprTag w ++ ">"
-               | isJust (S.stack w)      = " " ++ pprTag w ++ " "
+         fmt w | S.tag w == this         = "[" ++ S.tag w ++ "]"
+               | S.tag w `elem` visibles = "<" ++ S.tag w ++ ">"
+               | isJust (S.stack w)      = " " ++ S.tag w ++ " "
                | otherwise               = ""
 
 -- |
@@ -79,11 +154,7 @@ dynamicLogXinerama = withWindowSet $ io . putStrLn . pprWindowSetXinerama
 
 pprWindowSetXinerama :: WindowSet -> String
 pprWindowSetXinerama ws = "[" ++ unwords onscreen ++ "] " ++ unwords offscreen
-  where onscreen  = map (pprTag . S.workspace)
+  where onscreen  = map (S.tag . S.workspace)
                         . sortBy (comparing S.screen) $ S.current ws : S.visible ws
-        offscreen = map pprTag . filter (isJust . S.stack)
+        offscreen = map S.tag . filter (isJust . S.stack)
                         . sortBy (comparing S.tag) $ S.hidden ws
-
--- util functions
-pprTag :: Integral i => S.Workspace i a -> String
-pprTag = show . (+(1::Int)) . fromIntegral . S.tag

DynamicWorkspaces.hs

@@ -19,13 +19,11 @@ module XMonadContrib.DynamicWorkspaces (
                                          addWorkspace, removeWorkspace
                                        ) where
 
-import Control.Monad.State ( gets, modify )
+import Control.Monad.State ( gets )
 
-import XMonad ( X, XState(..), Layout, trace )
-import Operations ( windows, view )
-import StackSet ( tagMember, StackSet(..), Screen(..), Workspace(..),
-                  integrate, differentiate )
-import Data.Map ( delete, insert )
+import XMonad ( X, XState(..), Layout, WorkspaceId )
+import Operations
+import StackSet hiding (filter, modify, delete)
 import Graphics.X11.Xlib ( Window )
 
 -- $usage
@@ -33,33 +31,33 @@ import Graphics.X11.Xlib ( Window )
 -- 
 -- > import XMonadContrib.DynamicWorkspaces
 --
--- >   , ((modMask .|. shiftMask, xK_Up), addWorkspace defaultLayouts)
+-- >   , ((modMask .|. shiftMask, xK_Up), addWorkspace layouts)
 -- >   , ((modMask .|. shiftMask, xK_Down), removeWorkspace)
 
-addWorkspace :: [Layout Window] -> X ()
-addWorkspace (l:ls) = do s <- gets windowset
-                         let newtag:_ = filter (not . (`tagMember` s)) [0..]
-                         modify $ \st -> st { layouts = insert newtag (l,ls) $ layouts st }
-                         windows (addWorkspace' newtag)
-addWorkspace [] = trace "bad layouts in XMonadContrib.DynamicWorkspaces.addWorkspace\n"
+allPossibleTags :: [WorkspaceId]
+allPossibleTags = map (:"") ['0'..]
+
+addWorkspace :: Layout Window -> X ()
+addWorkspace l = do s <- gets windowset
+                    let newtag:_ = filter (not . (`tagMember` s)) allPossibleTags
+                    windows (addWorkspace' newtag l)
 
 removeWorkspace :: X ()
 removeWorkspace = do s <- gets windowset
                      case s of
                        StackSet { current = Screen { workspace = torem }
                                 , hidden = (w:_) }
-                           -> do view $ tag w
-                                 modify $ \st -> st { layouts = delete (tag torem) $ layouts st }
+                           -> do windows $ view (tag w)
                                  windows (removeWorkspace' (tag torem))
                        _ -> return ()
 
-addWorkspace' :: i -> StackSet i a sid sd -> StackSet i a sid sd
-addWorkspace' newtag s@(StackSet { current = scr@(Screen { workspace = w })
-                                 , hidden = ws })
-    = s { current = scr { workspace = Workspace newtag Nothing }
+addWorkspace' :: i -> l -> StackSet i l a sid sd -> StackSet i l a sid sd
+addWorkspace' newtag l s@(StackSet { current = scr@(Screen { workspace = w })
+                                   , hidden = ws })
+    = s { current = scr { workspace = Workspace newtag l Nothing }
         , hidden = w:ws }
 
-removeWorkspace' :: (Eq i) => i -> StackSet i a sid sd -> StackSet i a sid sd
+removeWorkspace' :: (Eq i) => i -> StackSet i l a sid sd -> StackSet i l a sid sd
 removeWorkspace' torem s@(StackSet { current = scr@(Screen { workspace = wc })
                                    , hidden = (w:ws) })
     | tag w == torem = s { current = scr { workspace = wc { stack = meld (stack w) (stack wc) } }

EwmhDesktops.hs

@@ -0,0 +1,130 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module       : XMonadContrib.EwmhDesktops
+-- Copyright    : (c) Joachim Breitner <mail@joachim-breitner.de>
+-- License      : BSD
+--
+-- Maintainer   : Joachim Breitner <mail@joachim-breitner.de>
+-- Stability    : unstable
+-- Portability  : unportable
+--
+-- Makes xmonad use the EWMH hints to tell panel applications about its
+-- workspaces and the windows therein.
+-----------------------------------------------------------------------------
+module XMonadContrib.EwmhDesktops (
+    -- * Usage
+    -- $usage
+    ewmhDesktopsLogHook
+    ) where
+
+import Data.List    (elemIndex, sortBy)
+import Data.Ord     (comparing)
+import Data.Maybe   (fromMaybe)
+
+import Control.Monad.Reader
+import XMonad
+import qualified StackSet as W
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+
+import XMonadContrib.SetWMName
+
+-- $usage
+-- Add the imports to your configuration file and add the logHook:
+--
+-- > import XMonadContrib.EwmhDesktops
+--
+-- > logHook :: X()
+-- > logHook = do ewmhDesktopsLogHook
+-- >              return ()
+
+-- %import XMonadContrib.EwmhDesktops
+-- %def -- comment out default logHook definition above if you uncomment this:
+-- %def logHook = ewmhDesktopsLogHook
+
+
+-- |
+-- Notifies pagers and window lists, such as those in the gnome-panel
+-- of the current state of workspaces and windows.
+ewmhDesktopsLogHook :: X ()
+ewmhDesktopsLogHook = withWindowSet $ \s -> do
+    -- Bad hack because xmonad forgets the original order of things, it seems
+    -- see http://code.google.com/p/xmonad/issues/detail?id=53
+    let ws = sortBy (comparing W.tag) $ W.workspaces s
+    let wins = W.allWindows s
+
+    setSupported
+
+    -- Number of Workspaces
+    setNumberOfDesktops (length ws)
+
+    -- Names thereof
+    setDesktopNames (map W.tag ws)
+
+    -- Current desktop
+    fromMaybe (return ()) $ do
+        n <- W.lookupWorkspace 0 s
+        i <- elemIndex n $ map W.tag ws
+        return $ setCurrentDesktop i
+
+    setClientList wins
+
+    -- Per window Desktop
+    forM (zip ws [(0::Int)..]) $ \(w, wn) ->
+        forM (W.integrate' (W.stack w)) $ \win -> do
+            setWindowDesktop win wn
+
+    return ()
+
+
+setNumberOfDesktops :: (Integral a) => a -> X ()
+setNumberOfDesktops n = withDisplay $ \dpy -> do
+    a <- getAtom "_NET_NUMBER_OF_DESKTOPS"
+    c <- getAtom "CARDINAL"
+    r <- asks theRoot
+    io $ changeProperty32 dpy r a c propModeReplace [fromIntegral n]
+
+setCurrentDesktop :: (Integral a) => a -> X ()
+setCurrentDesktop i = withDisplay $ \dpy -> do
+    a <- getAtom "_NET_CURRENT_DESKTOP"
+    c <- getAtom "CARDINAL"
+    r <- asks theRoot
+    io $ changeProperty32 dpy r a c propModeReplace [fromIntegral i]
+
+setDesktopNames :: [String] -> X ()
+setDesktopNames names = withDisplay $ \dpy -> do
+    -- Names thereof
+    r <- asks theRoot
+    a <- getAtom "_NET_DESKTOP_NAMES"
+    c <- getAtom "UTF8_STRING"
+    let names' = map (fromIntegral.fromEnum) $
+            concatMap (("Workspace "++) . (++['\0'])) names
+    io $ changeProperty8 dpy r a c propModeReplace names'
+
+setClientList :: [Window] -> X ()
+setClientList wins = withDisplay $ \dpy -> do
+    -- (What order do we really need? Something about age and stacking)
+    r <- asks theRoot
+    c <- getAtom "WINDOW"
+    a <- getAtom "_NET_CLIENT_LIST"
+    io $ changeProperty32 dpy r a c propModeReplace (fmap fromIntegral wins)
+    a' <- getAtom "_NET_CLIENT_LIST_STACKING"
+    io $ changeProperty32 dpy r a' c propModeReplace (fmap fromIntegral wins)
+
+setWindowDesktop :: (Integral a) => Window -> a -> X ()
+setWindowDesktop win i = withDisplay $ \dpy -> do
+    a <- getAtom "_NET_WM_DESKTOP"
+    c <- getAtom "CARDINAL"
+    io $ changeProperty32 dpy win a c propModeReplace [fromIntegral i]
+
+setSupported :: X ()
+setSupported = withDisplay $ \dpy -> do
+    r <- asks theRoot
+    a <- getAtom "_NET_SUPPORTED"
+    c <- getAtom "ATOM"
+    supp <- mapM getAtom ["_NET_WM_STATE_HIDDEN"]
+    io $ changeProperty32 dpy r a c propModeReplace (fmap fromIntegral supp)
+
+    setWMName "xmonad"
+
+

FindEmptyWorkspace.hs

@@ -25,7 +25,7 @@ import Data.Maybe ( isNothing )
 import XMonad
 import StackSet
 
-import qualified Operations as O
+import Operations
 
 -- $usage
 -- 
@@ -41,12 +41,16 @@ import qualified Operations as O
 -- Now you can jump to an empty workspace with mod-m. Mod-shift-m will
 -- tag the current window to an empty workspace and view it.
 
+-- %import XMonadContrib.FindEmptyWorkspace
+-- %keybind , ((modMask,                xK_m    ), viewEmptyWorkspace)
+-- %keybind , ((modMask .|. shiftMask,  xK_m    ), tagToEmptyWorkspace)
+
 
 -- | Find the first hidden empty workspace in a StackSet. Returns
 -- Nothing if all workspaces are in use. Function searches currently
 -- focused workspace, other visible workspaces (when in Xinerama) and
 -- hidden workspaces in this order.
-findEmptyWorkspace :: StackSet i a s sd -> Maybe (Workspace i a)
+findEmptyWorkspace :: StackSet i l a s sd -> Maybe (Workspace i l a)
 findEmptyWorkspace = find (isNothing . stack) . allWorkspaces
   where
     allWorkspaces ss = (workspace . current) ss :
@@ -60,9 +64,9 @@ withEmptyWorkspace f = do
 -- | Find and view an empty workspace. Do nothing if all workspaces are
 -- in use.
 viewEmptyWorkspace :: X ()
-viewEmptyWorkspace = withEmptyWorkspace O.view
+viewEmptyWorkspace = withEmptyWorkspace (windows . view)
 
 -- | Tag current window to an empty workspace and view it. Do nothing if
 -- all workspaces are in use.
 tagToEmptyWorkspace :: X ()
-tagToEmptyWorkspace = withEmptyWorkspace $ \w -> O.shift w >> O.view w
+tagToEmptyWorkspace = withEmptyWorkspace $ \w -> windows $ view w . shift w

FlexibleManipulate.hs

@@ -1,4 +1,5 @@
-{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.FlexibleManipulate
@@ -42,12 +43,15 @@ import Graphics.X11.Xlib.Extras
 --    is divided by thirds for each axis)
 -- Flex.resize performs only resize of the window, based on which quadrant
 --    the mouse is in
--- Flex.position is similar to the builtin mouseMoveWindow
+-- Flex.position is similar to the built-in mouseMoveWindow
 --
 -- You can also write your own function for this parameter. It should take
 -- a value between 0 and 1 indicating position, and return a value indicating
 -- the corresponding position if plain Flex.linear was used.
 
+-- %import qualified XMonadContrib.FlexibleManipulate as Flex
+-- %mousebind , ((modMask, button1), (\\w -> focus w >> Flex.mouseWindow Flex.linear w))
+
 discrete, linear, resize, position :: Double -> Double
 
 discrete x | x < 0.33 = 0
@@ -76,7 +80,7 @@ mouseWindow f w = whenX (isClient w) $ withDisplay $ \d -> do
             npos = wpos + offset * atl
             nbr = (wpos + wsize) + offset * abr
             ntl = minP (nbr - (32, 32)) npos    --minimum size
-            nwidth = applySizeHints sh $ mapP round (nbr - ntl)
+            nwidth = applySizeHints sh $ mapP (round :: Double -> Integer) (nbr - ntl)
         moveResizeWindow d w (round $ fst ntl) (round $ snd ntl) `uncurry` nwidth
         return ())
         (float w)

FlexibleResize.hs

@@ -32,6 +32,9 @@ import Foreign.C.Types
 -- >     [ ...
 -- >     , ((modMask, button3), (\w -> focus w >> Flex.mouseResizeWindow w)) ]
 
+-- %import qualified XMonadContrib.FlexibleResize as Flex
+-- %mousebind , ((modMask, button3), (\\w -> focus w >> Flex.mouseResizeWindow w))
+
 mouseResizeWindow :: Window -> X ()
 mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do
     io $ raiseWindow d w
@@ -57,8 +60,8 @@ mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do
     firstHalf a b = fromIntegral a * 2 <= b
     cfst = curry fst
     csnd = curry snd
-    mkSel :: Bool -> Position -> Position -> (Position, a -> a -> a, CInt -> Dimension)
+    mkSel :: Bool -> Position -> Position -> (Position, a -> a -> a, CInt -> Position)
     mkSel b k p =
         if b
-            then (0, csnd, fromIntegral . max 1 . ((k + p) -) . fromIntegral)
-            else (k, cfst, fromIntegral . max 1 . subtract p  . fromIntegral)
+            then (0, csnd, ((k + p) -) . fromIntegral)
+            else (k, cfst, subtract p  . fromIntegral)

FloatKeys.hs

@@ -0,0 +1,112 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module       : XMonadContrib.FloatKeys
+-- Copyright    : (c) Karsten Schoelzel <kuser@gmx.de>
+-- License      : BSD
+--
+-- Maintainer   : Karsten Schoelzel <kuser@gmx.de>
+-- Stability    : unstable
+-- Portability  : unportable
+--
+-- Move and resize floating windows.
+-----------------------------------------------------------------------------
+
+module XMonadContrib.FloatKeys (
+                -- * Usage
+                -- $usage
+                keysMoveWindow,
+                keysMoveWindowTo,
+                keysResizeWindow,
+                keysAbsResizeWindow) where
+
+import Operations
+import XMonad
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+
+-- $usage
+-- > import XMonadContrib.FloatKeys
+--
+-- >  , ((modMask,               xK_d     ), withFocused (keysResizeWindow (-10,-10) (1,1))) 
+-- >  , ((modMask,               xK_s     ), withFocused (keysResizeWindow (10,10) (1,1))) 
+-- >  , ((modMask .|. shiftMask, xK_d     ), withFocused (keysAbsResizeWindow (-10,-10) (1024,752))) 
+-- >  , ((modMask .|. shiftMask, xK_s     ), withFocused (keysAbsResizeWindow (10,10) (1024,752))) 
+-- >  , ((modMask,               xK_a     ), withFocused (keysMoveWindowTo (512,384) (1%2,1%2)))
+--
+--
+-- keysMoveWindow (dx, dy) moves the window by dx pixels to the right and dy pixels down
+--
+-- keysMoveWindowTo (x, y) (gx, gy) moves the window relative point (gx, gy) to the point (x,y)
+--      where (gx,gy) gives a position relative to the window border, i.e.
+--      gx = 0 is the left border and gx = 1 the right border
+--      gy = 0 is the top border  and gy = 1 the bottom border
+--
+--      examples on a 1024x768 screen: keysMoveWindowTo (512,384) (1%2, 1%2) centers the window on screen
+--                                     keysMoveWindowTo (1024,0) (1, 0) puts it into the top right corner
+--
+-- keysResizeWindow (dx, dy) (gx, gy) changes the width by dx and the height by dy leaving the window
+--      relative point (gx, gy) fixed
+--
+--      examples: keysResizeWindow (10, 0) (0, 0) makes the window 10 pixels larger to the right
+--                keysResizeWindow (10, 0) (0, 1%2) does the same, unless sizeHints are applied
+--                keysResizeWindow (10, 10) (1%2, 1%2) adds 5 pixels on each side
+--                keysResizeWindow (-10, -10) (0, 1) shrinks the window in direction of the bottom-left corner
+--              
+--  keysAbsResizeWindow (dx, dy) (ax, ay) changes the width by dx and the height by dy leaving the screen
+--      absolut point (ax, ay) fixed
+--
+--      examples on a 1024x768 screen: keysAbsResizeWindow (10, 10) (0, 0) enlarge the window and if it is not in the top-left corner it will also be moved away
+--
+keysMoveWindow :: D -> Window -> X ()
+keysMoveWindow (dx,dy) w = whenX (isClient w) $ withDisplay $ \d -> do
+    io $ raiseWindow d w
+    wa <- io $ getWindowAttributes d w
+    io $ moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + dx))
+                        (fromIntegral (fromIntegral (wa_y wa) + dy))
+    float w
+
+keysMoveWindowTo :: P -> G -> Window -> X ()
+keysMoveWindowTo (x,y) (gx, gy) w = whenX (isClient w) $ withDisplay $ \d -> do
+    io $ raiseWindow d w
+    wa <- io $ getWindowAttributes d w
+    io $ moveWindow d w (x - round (gx * fromIntegral (wa_width wa)))
+                        (y - round (gy * fromIntegral (wa_height wa)))
+    float w
+
+type G = (Rational, Rational)
+type P = (Position, Position)
+
+keysResizeWindow :: D -> G -> Window -> X ()
+keysResizeWindow = keysMoveResize keysResizeWindow'
+
+keysAbsResizeWindow :: D -> D -> Window -> X ()
+keysAbsResizeWindow = keysMoveResize keysAbsResizeWindow'
+
+keysAbsResizeWindow' :: SizeHints -> P -> D -> D -> D -> (P,D)
+keysAbsResizeWindow' sh (x,y) (w,h) (dx,dy) (ax, ay) = ((round nx, round ny), (nw, nh))
+    where
+        (nw, nh) = applySizeHints sh (w + dx, h + dy)
+        nx :: Rational
+        nx = fromIntegral (ax * w + nw * (fromIntegral x - ax)) / fromIntegral w
+        ny :: Rational
+        ny = fromIntegral (ay * h + nh * (fromIntegral y - ay)) / fromIntegral h
+
+keysResizeWindow' :: SizeHints -> P -> D -> D -> G -> (P,D)
+keysResizeWindow' sh (x,y) (w,h) (dx,dy) (gx, gy) = ((nx, ny), (nw, nh))
+    where
+        (nw, nh) = applySizeHints sh (w + dx, h + dy)
+        nx = round $ fromIntegral x + gx * fromIntegral w - gx * fromIntegral nw
+        ny = round $ fromIntegral y + gy * fromIntegral h - gy * fromIntegral nh
+
+keysMoveResize :: (SizeHints -> P -> D -> a -> b -> (P,D)) -> a -> b -> Window -> X ()
+keysMoveResize f move resize w = whenX (isClient w) $ withDisplay $ \d -> do
+    io $ raiseWindow d w
+    wa <- io $ getWindowAttributes d w
+    sh <- io $ getWMNormalHints d w
+    let wa_dim = (fromIntegral $ wa_width wa, fromIntegral $ wa_height wa)
+        wa_pos = (fromIntegral $ wa_x wa, fromIntegral $ wa_y wa)
+        (wn_pos, wn_dim) = f sh wa_pos wa_dim move resize 
+    io $ resizeWindow d w `uncurry` wn_dim
+    io $ moveWindow d w `uncurry` wn_pos
+    float w
+

FocusNth.hs

@@ -8,7 +8,7 @@
 -- Stability    : unstable
 -- Portability  : unportable
 --
--- Focus the n'th window on the screen.
+-- Focus the nth window on the screen.
 -----------------------------------------------------------------------------
 
 module XMonadContrib.FocusNth (
@@ -27,6 +27,12 @@ import XMonad
 -- > ++ [((mod4Mask, k), focusNth i)
 -- >     | (i, k) <- zip [0 .. 8] [xK_1 ..]]
 
+-- %import XMonadContrib.FocusNth
+-- %keybdindextra ++
+-- %keybdindextra -- mod4-[1..9] @@ Switch to window N
+-- %keybdindextra [((mod4Mask, k), focusNth i)
+-- %keybdindextra     | (i, k) <- zip [0 .. 8] [xK_1 ..]]
+
 focusNth :: Int -> X ()
 focusNth = windows . modify' . focusNth'
 

Grid.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.Grid
+-- Copyright   :  (c) Lukas Mai
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  <l.mai@web.de>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- A simple layout that attempts to put all windows in a square grid.
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.Grid (
+    -- * Usage
+    -- $usage
+	Grid(..)
+) where
+
+import XMonad
+import StackSet
+import Graphics.X11.Xlib.Types
+
+-- $usage
+-- Put the following in your Config.hs file:
+--
+-- > import XMonadContrib.Grid
+-- > ...
+-- > layouts = [ ...
+-- >                  , Layout Grid
+-- >                  ]
+
+-- %import XMonadContrib.Grid
+-- %layout , Layout Grid
+
+data Grid a = Grid deriving (Read, Show)
+
+instance LayoutClass Grid a where
+    pureLayout Grid r s = arrange r (integrate s)
+
+arrange :: Rectangle -> [a] -> [(a, Rectangle)]
+arrange (Rectangle rx ry rw rh) st = zip st rectangles
+	where
+	nwins = length st
+	ncols = ceiling . (sqrt :: Double -> Double) . fromIntegral $ nwins
+	mincs = nwins `div` ncols
+	extrs = nwins - ncols * mincs
+	chop :: Int -> Dimension -> [(Position, Dimension)]
+	chop n m = ((0, m - k * fromIntegral (pred n)) :) . map (flip (,) k) . tail . reverse . take n . tail . iterate (subtract k') $ m'
+		where
+		k :: Dimension
+		k = m `div` fromIntegral n
+		m' = fromIntegral m
+		k' :: Position
+		k' = fromIntegral k
+	xcoords = chop ncols rw
+	ycoords = chop mincs rh
+	ycoords' = chop (succ mincs) rh
+	(xbase, xext) = splitAt (ncols - extrs) xcoords
+	rectangles = combine ycoords xbase ++ combine ycoords' xext
+		where
+		combine ys xs = [Rectangle (rx + x) (ry + y) w h | (x, w) <- xs, (y, h) <- ys]

HintedTile.hs

@@ -31,7 +31,11 @@ import Control.Monad
 --
 -- > import qualified XMonadContrib.HintedTile
 --
--- > defaultLayouts = [ XMonadContrib.HintedTile.tall nmaster delta ratio, ... ]
+-- > layouts = [ XMonadContrib.HintedTile.tall nmaster delta ratio, ... ]
+
+-- %import qualified XMonadContrib.HintedTile
+--
+-- %layout , XMonadContrib.HintedTile.tall nmaster delta ratio
 
 -- this sucks
 addBorder, substractBorder :: (Dimension, Dimension) -> (Dimension, Dimension)

Invisible.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.Invisible
+-- Copyright   :  (c) 2007 Andrea Rossato, David Roundy
+-- License     :  BSD-style (see xmonad/LICENSE)
+-- 
+-- Maintainer  :  andrea.rossato@unibz.it, droundy@darcs.net
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- A data type to store the layout state
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.Invisible ( 
+                             -- * Usage:
+                             -- $usage
+                             Invisible (..)
+                            , whenIJust
+                            , fromIMaybe
+                            ) where
+
+-- $usage
+-- A data type to store the layout state
+
+newtype Invisible m a = I (m a) deriving (Monad, Functor)
+
+instance (Functor m, Monad m) => Read (Invisible m a) where
+    readsPrec _ s = [(fail "Read Invisible", s)]
+
+instance Monad m => Show (Invisible m a) where
+    show _ = ""
+
+whenIJust :: (Monad m) => Invisible Maybe a -> (a -> m ()) -> m ()
+whenIJust (I (Just x)) f  = f x
+whenIJust (I  Nothing) _  = return ()
+
+fromIMaybe :: a -> Invisible Maybe a -> a
+fromIMaybe _ (I (Just x)) = x
+fromIMaybe a (I  Nothing) = a

LayoutHelpers.hs

@@ -1,62 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module       : XMonadContrib.LayoutHelpers
--- Copyright    : (c) David Roundy <droundy@darcs.net>
--- License      : BSD
---
--- Maintainer   : David Roundy <droundy@darcs.net>
--- Stability    : unstable
--- Portability  : portable
---
--- A module for writing easy Layouts
------------------------------------------------------------------------------
-
-module XMonadContrib.LayoutHelpers (
-    -- * Usage
-    -- $usage
-    DoLayout, ModDo, ModMod, ModLay,
-    layoutModify,
-    l2lModDo, idModify,
-    idModDo, idModMod,
-    ) where
-
-import Graphics.X11.Xlib ( Rectangle )
-import XMonad
-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 ModifyLayout a = SomeMessage -> X (Maybe (Layout a))
-
-type ModDo a = Rectangle -> Stack a -> [(a, Rectangle)] -> X ([(a, Rectangle)], Maybe (ModLay a))
-type ModMod a = SomeMessage -> X (Maybe (ModLay a))
-
-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', mmod') <- fdo r s 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
-                               Just mod' -> Just $ mod' $ maybe l id ml'
-                               Nothing -> layoutModify fdo fmod `fmap` ml'
-
-l2lModDo :: (Rectangle -> [a] -> [(a,Rectangle)]) -> DoLayout a
-l2lModDo dl r s = return (dl r $ integrate s, Nothing)
-
-idModDo :: ModDo a
-idModDo _ _ wrs = return (wrs, Nothing)
-
-idModify :: ModifyLayout a
-idModify _ = return Nothing
-
-idModMod :: ModMod a
-idModMod _ = return Nothing

LayoutHints.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module       : XMonadContrib.LayoutHints
@@ -14,30 +16,42 @@
 module XMonadContrib.LayoutHints (
     -- * usage
     -- $usage
-    layoutHints) where
+    layoutHints,
+    LayoutHints) where
 
 import Operations ( applySizeHints, D )
 import Graphics.X11.Xlib
 import Graphics.X11.Xlib.Extras ( getWMNormalHints )
 import {-#SOURCE#-} Config (borderWidth)
 import XMonad hiding ( trace )
-import XMonadContrib.LayoutHelpers ( layoutModify, idModMod )
+import XMonadContrib.LayoutModifier
 
 -- $usage
 -- > import XMonadContrib.LayoutHints
--- > defaultLayouts = [ layoutHints tiled , layoutHints $ mirror tiled ]
+-- > layouts = [ layoutHints tiled , layoutHints $ Mirror tiled ]
+
+-- %import XMonadContrib.LayoutHints
+-- %layout , layoutHints $ tiled
+-- %layout , layoutHints $ Mirror tiled
+
+layoutHints :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHints l a
+layoutHints = ModifiedLayout LayoutHints
 
 -- | Expand a size by the given multiple of the border width.  The
 -- multiple is most commonly 1 or -1.
 adjBorders             :: Dimension -> D -> D
 adjBorders mult (w,h)  = (w+2*mult*borderWidth, h+2*mult*borderWidth)
 
-layoutHints :: Layout Window -> Layout Window
-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)
-                     return (w, Rectangle a b c' d')
+data LayoutHints a = LayoutHints deriving (Read, Show)
+
+instance LayoutModifier LayoutHints Window where
+    modifierDescription _ = "Hinted"
+    redoLayout _ _ _ xs = do
+                            xs' <- mapM applyHint xs
+                            return (xs', Nothing)
+     where
+        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)
+                return (w, Rectangle a b c' d')

LayoutHooks.hs

@@ -1,44 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module       : XMonadContrib.LayoutHooks
--- Copyright    : (c) Stefan O'Rear <stefanor@cox.net>
--- License      : BSD
---
--- Maintainer   : Stefan O'Rear <stefanor@cox.net>
--- Stability    : unstable
--- Portability  : portable
---
--- General layout-level hooks.
------------------------------------------------------------------------------
-
-module XMonadContrib.LayoutHooks ( addLayoutMessageHook ) where
-
-import qualified Data.Map as M  ( adjust  )
-import Control.Arrow            ( first   )
-import Control.Monad.State      ( modify  )
-
-import XMonad
-import qualified StackSet as W
-
-install :: (SomeMessage -> X Bool) -> Layout a -> Layout a
-install hk lay = lay{ modifyLayout = mod' }
-  where
-    mod' msg = do reinst  <- hk msg
-                  nlay    <- modifyLayout lay msg
-
-                  return $ cond_reinst reinst nlay
-
-    -- no need to make anything change
-    cond_reinst True   Nothing      = Nothing
-    -- reinstall
-    cond_reinst True   (Just nlay)  = Just (install hk nlay)
-    -- restore inner layout
-    cond_reinst False  Nothing      = Just lay
-    -- let it rot
-    cond_reinst False  (Just nlay)  = Just nlay
-
--- Return True each time you want the hook reinstalled
-addLayoutMessageHook     :: (SomeMessage -> X Bool) -> X ()
-addLayoutMessageHook hk  = modify $ \ s ->
-    let nr = W.tag . W.workspace . W.current . windowset $ s
-      in s { layouts = M.adjust (first $ install hk) nr (layouts s) }

LayoutModifier.hs

@@ -0,0 +1,63 @@
+{-# -fglasgow-exts #-} -- For deriving Data/Typeable
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module       : XMonadContrib.LayoutModifier
+-- Copyright    : (c) David Roundy <droundy@darcs.net>
+-- License      : BSD
+--
+-- Maintainer   : David Roundy <droundy@darcs.net>
+-- Stability    : unstable
+-- Portability  : portable
+--
+-- A module for writing easy Layouts
+-----------------------------------------------------------------------------
+
+module XMonadContrib.LayoutModifier (
+    -- * Usage
+    -- $usage
+    LayoutModifier(..), ModifiedLayout(..)
+    ) where
+
+import Graphics.X11.Xlib ( Rectangle )
+import XMonad
+import StackSet ( Stack )
+import Operations ( LayoutMessages(Hide, ReleaseResources) )
+
+-- $usage
+-- Use LayoutHelpers to help write easy Layouts.
+
+class (Show (m a), Read (m a)) => LayoutModifier m a where
+    handleMess :: m a -> SomeMessage -> X (Maybe (m a))
+    handleMess m mess | Just Hide <- fromMessage mess             = doUnhook
+                        | Just ReleaseResources <- fromMessage mess = doUnhook
+                        | otherwise = return Nothing
+     where doUnhook = do unhook m; return Nothing
+    redoLayout :: m a -> Rectangle -> Stack a -> [(a, Rectangle)]
+               -> X ([(a, Rectangle)], Maybe (m a))
+    redoLayout m _ _ wrs = do hook m; return (wrs, Nothing)
+    hook :: m a -> X ()
+    hook _ = return ()
+    unhook :: m a -> X ()
+    unhook _ = return ()
+    modifierDescription :: m a -> String
+    modifierDescription = show
+
+instance (LayoutModifier m a, LayoutClass l a) => LayoutClass (ModifiedLayout m l) a where
+    doLayout (ModifiedLayout m l) r s =
+        do (ws, ml') <- doLayout l r s
+           (ws', mm') <- redoLayout m r s ws
+           let ml'' = case mm' of
+                      Just m' -> Just $ (ModifiedLayout m') $ maybe l id ml'
+                      Nothing -> ModifiedLayout m `fmap` ml'
+           return (ws', ml'')
+    handleMessage (ModifiedLayout m l) mess =
+        do ml' <- handleMessage l mess
+           mm' <- handleMess m mess
+           return $ case mm' of
+                    Just m' -> Just $ (ModifiedLayout m') $ maybe l id ml'
+                    Nothing -> (ModifiedLayout m) `fmap` ml'
+    description (ModifiedLayout m l) = modifierDescription m ++ " " ++ description l
+
+data ModifiedLayout m l a = ModifiedLayout (m a) (l a) deriving ( Read, Show )

LayoutScreens.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.LayoutScreens
@@ -13,7 +15,7 @@
 module XMonadContrib.LayoutScreens (
                                     -- * Usage
                                     -- $usage
-                                    layoutScreens
+                                    layoutScreens, fixedLayout
                                    ) where
 
 import Control.Monad.Reader ( asks )
@@ -30,17 +32,31 @@ import Graphics.X11.Xlib.Extras
 -- separate screens.  This should definitely be useful for testing the
 -- behavior of xmonad under Xinerama, and it's possible that it'd also be
 -- handy for use as an actual user interface, if you've got a very large
--- sceen and long for greater flexibility (e.g. being able to see your
+-- screen and long for greater flexibility (e.g. being able to see your
 -- email window at all times, a crude mimic of sticky windows).
 --
 -- You can use this module with the following in your Config.hs file:
 -- 
 -- > import XMonadContrib.LayoutScreens
 --
--- >   , ((modMask .|. shiftMask, xK_space), layoutScreens 2 (twoPane 0.5 0.5))
+-- >   , ((modMask .|. shiftMask, xK_space), layoutScreens 2 (TwoPane 0.5 0.5))
+-- >   , ((controlMask .|. modMask .|. shiftMask, xK_space), rescreen)
+--
+-- Another example use would be to handle a scenario where xrandr didn't
+-- work properly (e.g. a VNC X server in my case) and you want to be able
+-- to resize your screen (e.g. to match the size of a remote VNC client):
+-- 
+-- > import XMonadContrib.LayoutScreens
+--
+-- >   , ((modMask .|. shiftMask, xK_space),
+-- >        layoutScreens 1 (fixedLayout $ Rectangle 0 0 1024 768))
 -- >   , ((controlMask .|. modMask .|. shiftMask, xK_space), rescreen)
 
-layoutScreens :: Int -> Layout Int -> X ()
+-- %import XMonadContrib.LayoutScreens
+-- %keybind , ((modMask .|. shiftMask, xK_space), layoutScreens 2 (twoPane 0.5 0.5))
+-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_space), rescreen)
+
+layoutScreens :: LayoutClass l Int => Int -> l Int -> X ()
 layoutScreens nscr _ | nscr < 1 = trace $ "Can't layoutScreens with only " ++ show nscr ++ " screens."
 layoutScreens nscr l =
     do rtrect <- asks theRoot >>= getWindowRectangle
@@ -58,3 +74,11 @@ getWindowRectangle w = withDisplay $ \d ->
     do a <- io $ getWindowAttributes d w
        return $ Rectangle (fromIntegral $ wa_x a)     (fromIntegral $ wa_y a)
                           (fromIntegral $ wa_width a) (fromIntegral $ wa_height a)
+
+data FixedLayout a = FixedLayout [Rectangle] deriving (Read,Show)
+
+instance LayoutClass FixedLayout a where
+    doLayout (FixedLayout rs) _ s = return (zip (W.integrate s) rs, Nothing)
+
+fixedLayout :: [Rectangle] -> FixedLayout a
+fixedLayout = FixedLayout

MagicFocus.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module       : XMonadContrib.MagicFocus
@@ -11,22 +13,38 @@
 -- Automagically put the focused window in the master area.
 -----------------------------------------------------------------------------
 
-module XMonadContrib.MagicFocus (
-                 -- * Usage
-                 -- $usage
-                 magicFocus) where
+module XMonadContrib.MagicFocus 
+    (-- * Usage
+     -- $usage
+     MagicFocus(MagicFocus)
+    ) where
 
-import Graphics.X11.Xlib (Window)
+import Graphics.X11.Xlib
 import XMonad
 import StackSet
 
 -- $usage
 -- > import XMonadContrib.MagicFocus
--- > defaultLayouts = [ magicFocus tiled , magicFocus $ mirror tiled ]
+-- > layouts = [ Layout $ MagicFocus tiled , Layout $ MagicFocus $ Mirror tiled ]
 
-magicFocus :: Layout Window -> Layout Window
-magicFocus l = l { doLayout = \r s -> withWindowSet (return . peek) >>= (doLayout l) r . swap s
-                 , modifyLayout = \x -> fmap magicFocus `fmap` modifyLayout l x }
+-- %import XMonadContrib.MagicFocus
+-- %layout , Layout $ MagicFocus tiled
+-- %layout , Layout $ MagicFocus $ Mirror tiled
+
+
+data MagicFocus l a = MagicFocus (l a) deriving ( Show , Read )
+
+instance (LayoutClass l Window) => LayoutClass (MagicFocus l) Window where
+          doLayout = magicFocus
+
+magicFocus :: LayoutClass l Window => MagicFocus l Window -> Rectangle
+           -> Stack Window -> X ([(Window, Rectangle)], Maybe (MagicFocus l Window))
+magicFocus (MagicFocus l) r s = 
+    withWindowSet $ \wset -> do
+      (ws,nl) <- doLayout l r (swap s $ peek wset)
+      case nl of
+        Nothing -> return (ws, Nothing)
+        Just l' -> return (ws, Just $ MagicFocus l')
 
 swap :: (Eq a) => Stack a -> Maybe a -> Stack a
 swap (Stack f u d) focused | Just f == focused = Stack f [] (reverse u ++ d)

Magnifier.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fglasgow-exts #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.Magnifier
@@ -28,7 +29,11 @@ import XMonadContrib.LayoutHelpers
 
 -- $usage
 -- > import XMonadContrib.Magnifier
--- > defaultLayouts = [ magnifier tiled , magnifier $ mirror tiled ]
+-- > layouts = [ magnifier tiled , magnifier $ mirror tiled ]
+
+-- %import XMonadContrib.Magnifier
+-- %layout , magnifier tiled
+-- %layout , magnifier $ mirror tiled
 
 -- | Increase the size of the window that has focus, unless it is the master window.
 magnifier :: Layout Window -> Layout Window

ManageDocks.hs

@@ -0,0 +1,102 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module       : XMonadContrib.ManageDocks
+-- Copyright    : (c) Joachim Breitner <mail@joachim-breitner.de>
+-- License      : BSD
+--
+-- Maintainer   : Joachim Breitner <mail@joachim-breitner.de>
+-- Stability    : unstable
+-- Portability  : unportable
+--
+-- Makes xmonad detect windows with type DOCK and does not put them in
+-- layouts. It also detects window with STRUT set and modifies the
+-- gap accordingly.
+--
+-- Cheveats:
+--
+--  * Only acts on STRUT apps on creation, not if you move or close them
+--
+--  * To reset the gap, press Mod-b twice and restart xmonad (Mod-q)
+-----------------------------------------------------------------------------
+module XMonadContrib.ManageDocks (
+    -- * Usage
+    -- $usage
+    manageDocksHook
+    ) where
+
+import Control.Monad.Reader
+import XMonad
+import Operations
+import qualified StackSet as W
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+import Data.Word
+
+-- $usage
+-- Add the imports to your configuration file and add the mangeHook:
+--
+-- > import XMonadContrib.ManageDocks
+--
+-- > manageHook w _ _ _  = manageDocksHook w
+--
+-- and comment out the default `manageHook _ _ _ _ = return id` line.
+
+-- %import XMonadContrib.ManageDocks
+-- %def -- comment out default manageHook definition above if you uncomment this:
+-- %def manageHook w _ _ _ = manageDocksHook w
+
+
+-- |
+-- Detects if the given window is of type DOCK and if so, reveals it, but does
+-- not manage it. If the window has the STRUT property set, adjust the gap accordingly.
+manageDocksHook :: Window -> X (WindowSet -> WindowSet)
+manageDocksHook w = do
+    hasStrut <- getStrut w
+    maybe (return ()) setGap hasStrut
+
+    isDock <- checkDock w
+    if isDock then do
+        reveal w
+        return (W.delete w)
+          else do
+            return id
+
+-- |
+-- Checks if a window is a DOCK window
+checkDock :: Window -> X (Bool)
+checkDock w = do
+    a <- getAtom "_NET_WM_WINDOW_TYPE"
+    d <- getAtom "_NET_WM_WINDOW_TYPE_DOCK"
+    mbr <- getProp a w
+    case mbr of
+        Just [r] -> return (fromIntegral r == d)
+        _        -> return False
+
+-- |
+-- Gets the STRUT config, if present, in xmonad gap order
+getStrut :: Window -> X (Maybe (Int, Int, Int, Int))
+getStrut w = do
+    a <- getAtom "_NET_WM_STRUT"
+    mbr <- getProp a w
+    case mbr of
+        Just [l,r,t,b] -> return (Just (
+                    fromIntegral t,
+                    fromIntegral b,
+                    fromIntegral l,
+                    fromIntegral r))
+        _              -> return Nothing
+
+-- |
+-- Helper to read a property
+getProp :: Atom -> Window -> X (Maybe [Word32])
+getProp a w = withDisplay $ \dpy -> io $ getWindowProperty32 dpy a w
+
+-- |
+-- Modifies the gap, setting new max
+setGap :: (Int, Int, Int, Int) -> X ()
+setGap gap = modifyGap (\_ -> max4 gap)
+
+-- |
+-- Piecewise maximum of a 4-tuple of Ints
+max4 :: (Int, Int, Int, Int) -> (Int, Int, Int, Int) -> (Int, Int, Int, Int)
+max4 (a1,a2,a3,a4) (b1,b2,b3,b4) = (max a1 b1, max a2 b2, max a3 b3, max a4 b4)

Maximize.hs

@@ -0,0 +1,73 @@
+{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.Maximize
+-- Copyright   :  (c) 2007 James Webb
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  xmonad#jwebb,sygneca,com
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Temporarily yanks the focused window out of the layout to mostly fill
+-- the screen.
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.Maximize (
+        -- * Usage
+        -- $usage
+        maximize,
+        maximizeRestore
+    ) where
+
+import Graphics.X11.Xlib
+import XMonad
+import XMonadContrib.LayoutModifier
+import Data.List ( partition )
+
+-- $usage
+-- You can use this module with the following in your Config.hs file:
+--
+-- > import XMonadContrib.Maximize
+--
+-- > layouts = ...
+-- >                  , Layout $ maximize $ tiled ...
+-- >                  ...
+--
+-- > keys = ...
+-- >        , ((modMask, xK_backslash), withFocused (sendMessage . maximizeRestore))
+-- >        ...
+
+-- %import XMonadContrib.Maximize
+-- %layout , Layout $ maximize $ tiled
+
+data Maximize a = Maximize (Maybe Window) deriving ( Read, Show )
+maximize :: LayoutClass l Window => l Window -> ModifiedLayout Maximize l Window
+maximize = ModifiedLayout $ Maximize Nothing
+
+data MaximizeRestore = MaximizeRestore Window deriving ( Typeable, Eq )
+instance Message MaximizeRestore
+maximizeRestore :: Window -> MaximizeRestore
+maximizeRestore = MaximizeRestore
+
+instance LayoutModifier Maximize Window where
+    modifierDescription (Maximize _) = "Maximize"
+    redoLayout (Maximize mw) rect _ wrs = case mw of
+        Just win ->
+                return (maxed ++ rest, Nothing)
+            where
+                maxed = map (\(w, _) -> (w, maxRect)) toMax
+                (toMax, rest) = partition (\(w, _) -> w == win) wrs
+                maxRect = Rectangle (rect_x rect + 50) (rect_y rect + 50)
+                    (rect_width rect - 100) (rect_height rect - 100)
+        Nothing -> return (wrs, Nothing)
+    handleMess (Maximize mw) m = case fromMessage m of
+        Just (MaximizeRestore w) -> case mw of
+            Just _ -> return $ Just $ Maximize Nothing
+            Nothing -> return $ Just $ Maximize $ Just w
+        _ -> return Nothing
+
+-- vim: sw=4:et

MetaModule.hs

@@ -23,49 +23,67 @@ import XMonadContrib.Accordion ()
 import XMonadContrib.Anneal ()
 import XMonadContrib.Circle ()
 import XMonadContrib.Commands ()
-import XMonadContrib.Combo ()
+import XMonadContrib.Combo () -- broken under ghc head
 import XMonadContrib.CopyWindow ()
-import XMonadContrib.Decoration ()
+import XMonadContrib.CycleWS ()
 import XMonadContrib.DeManage ()
 import XMonadContrib.DirectoryPrompt ()
+import XMonadContrib.Dishes ()
 import XMonadContrib.Dmenu ()
 import XMonadContrib.DragPane ()
 import XMonadContrib.DwmPromote ()
 import XMonadContrib.DynamicLog ()
 import XMonadContrib.DynamicWorkspaces ()
 import XMonadContrib.Dzen ()
+import XMonadContrib.EwmhDesktops ()
 import XMonadContrib.FindEmptyWorkspace ()
 import XMonadContrib.FlexibleResize ()
 import XMonadContrib.FlexibleManipulate ()
+import XMonadContrib.FloatKeys ()
 import XMonadContrib.FocusNth ()
-import XMonadContrib.HintedTile ()
-import XMonadContrib.LayoutHelpers ()
+import XMonadContrib.Grid ()
+import XMonadContrib.Invisible ()
+-- import XMonadContrib.HintedTile ()
+import XMonadContrib.LayoutModifier ()
 import XMonadContrib.LayoutHints ()
-import XMonadContrib.LayoutHooks ()
 import XMonadContrib.LayoutScreens ()
 import XMonadContrib.MagicFocus ()
-import XMonadContrib.Magnifier ()
-import XMonadContrib.Mosaic ()
+import XMonadContrib.ManageDocks ()
+-- import XMonadContrib.Magnifier ()
+import XMonadContrib.Maximize ()
+-- import XMonadContrib.Mosaic ()
+import XMonadContrib.MosaicAlt ()
+import XMonadContrib.MouseGestures ()
 import XMonadContrib.NamedWindows ()
 import XMonadContrib.NoBorders ()
+import XMonadContrib.ResizableTile ()
 import XMonadContrib.Roledex ()
 import XMonadContrib.RotSlaves ()
 import XMonadContrib.RotView ()
--- XMonadContrib.ShellPrompt depends on readline
---import XMonadContrib.ShellPrompt ()
+import XMonadContrib.RunInXTerm ()
+import XMonadContrib.SetWMName ()
+import XMonadContrib.ShellPrompt ()
 import XMonadContrib.SimpleDate ()
-import XMonadContrib.SimpleStacking ()
 import XMonadContrib.SinkAll ()
 import XMonadContrib.Spiral ()
 import XMonadContrib.Square ()
 import XMonadContrib.SshPrompt ()
 import XMonadContrib.Submap ()
+import XMonadContrib.SwapWorkspaces ()
 import XMonadContrib.SwitchTrans ()
 import XMonadContrib.Tabbed ()
+import XMonadContrib.TagWindows ()
 import XMonadContrib.ThreeColumns ()
 import XMonadContrib.TwoPane ()
 import XMonadContrib.ViewPrev ()
 import XMonadContrib.XMonadPrompt ()
 import XMonadContrib.XPrompt ()
+import XMonadContrib.XPropManage ()
+import XMonadContrib.XSelection ()
+import XMonadContrib.XUtils ()
 import XMonadContrib.Warp ()
+import XMonadContrib.WindowBringer ()
+import XMonadContrib.WindowNavigation ()
+import XMonadContrib.WindowPrompt ()
+import XMonadContrib.WmiiActions ()
 import XMonadContrib.WorkspaceDir ()

Mosaic.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS -fglasgow-exts #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.Mosaic
@@ -41,12 +42,12 @@ import XMonadContrib.Anneal
 --
 -- Key bindings:
 -- 
--- You can use this module with the following in your config file:
+-- You can use this module with the following in your Config.hs:
 --
 -- > import XMonadContrib.Mosaic
 --
--- > defaultLayouts :: [Layout Window]
--- > defaultLayouts = [ mosaic 0.25 0.5 M.empty, full ]
+-- > layouts :: [Layout Window]
+-- > layouts = [ mosaic 0.25 0.5 M.empty, full ]
 --
 -- In the key-bindings, do something like:
 --
@@ -59,6 +60,16 @@ import XMonadContrib.Anneal
 -- >   , ((controlMask .|. modMask .|. shiftMask, xK_o     ), withNamedWindow (sendMessage . flexibleWindow))
 -- 
 
+-- %import XMonadContrib.Mosaic
+-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_h), withNamedWindow (sendMessage . tallWindow))
+-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_l), withNamedWindow (sendMessage . wideWindow))
+-- %keybind , ((modMask .|. shiftMask, xK_h     ), withNamedWindow (sendMessage . shrinkWindow))
+-- %keybind , ((modMask .|. shiftMask, xK_l     ), withNamedWindow (sendMessage . expandWindow))
+-- %keybind , ((modMask .|. shiftMask, xK_s     ), withNamedWindow (sendMessage . squareWindow))
+-- %keybind , ((modMask .|. shiftMask, xK_o     ), withNamedWindow (sendMessage . myclearWindow))
+-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_o     ), withNamedWindow (sendMessage . flexibleWindow))
+-- %layout , mosaic 0.25 0.5 M.empty
+
 data HandleWindow = ExpandWindow NamedWindow | ShrinkWindow NamedWindow
                   | SquareWindow NamedWindow | ClearWindow NamedWindow
                   | TallWindow NamedWindow | WideWindow NamedWindow

MosaicAlt.hs

@@ -0,0 +1,163 @@
+{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable
+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.MosaicAlt
+-- Copyright   :  (c) 2007 James Webb
+-- License     :  BSD-style (see xmonad/LICENSE)
+-- 
+-- Maintainer  :  xmonad#jwebb,sygneca,com
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- A layout which gives each window a specified amount of screen space 
+-- relative to the others. Compared to the 'Mosaic' layout, this one
+-- divides the space in a more balanced way.
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.MosaicAlt (
+        -- * Usage:
+        -- $usage
+        MosaicAlt(..)
+        , shrinkWindowAlt
+        , expandWindowAlt
+        , tallWindowAlt
+        , wideWindowAlt
+        , resetAlt
+    ) where
+
+import XMonad
+import Operations
+import Graphics.X11.Xlib
+import qualified StackSet as W
+import qualified Data.Map as M
+import Data.List ( sortBy )
+import Data.Ratio
+import Graphics.X11.Types ( Window )
+
+-- $usage
+-- You can use this module with the following in your configuration file:
+--
+-- > import XMonadContrib.MosaicAlt
+--
+-- > layouts = ...
+-- >                  , Layout $ MosaicAlt M.empty
+-- >                  ...
+--
+-- > keys = ...
+-- >     , ((modMask .|. shiftMask, xK_a), withFocused (sendMessage . expandWindowAlt))
+-- >     , ((modMask .|. shiftMask, xK_z), withFocused (sendMessage . shrinkWindowAlt))
+-- >     , ((modMask .|. shiftMask, xK_s), withFocused (sendMessage . tallWindowAlt))
+-- >     , ((modMask .|. shiftMask, xK_d), withFocused (sendMessage . wideWindowAlt))
+-- >     , ((modMask .|. controlMask, xK_space), sendMessage resetAlt)
+-- >     ...
+
+-- %import XMonadContrib.MosaicAlt
+-- %layout , Layout $ MosaicAlt M.empty
+
+data HandleWindowAlt =
+    ShrinkWindowAlt Window
+    | ExpandWindowAlt Window
+    | TallWindowAlt Window
+    | WideWindowAlt Window
+    | ResetAlt
+    deriving ( Typeable, Eq )
+instance Message HandleWindowAlt
+shrinkWindowAlt, expandWindowAlt :: Window -> HandleWindowAlt
+tallWindowAlt, wideWindowAlt :: Window -> HandleWindowAlt
+shrinkWindowAlt = ShrinkWindowAlt
+expandWindowAlt = ExpandWindowAlt
+tallWindowAlt = TallWindowAlt
+wideWindowAlt = WideWindowAlt
+resetAlt :: HandleWindowAlt
+resetAlt = ResetAlt
+
+data Param = Param { area, aspect :: Rational } deriving ( Show, Read )
+type Params = M.Map Window Param
+data MosaicAlt a = MosaicAlt Params deriving ( Show, Read )
+
+instance LayoutClass MosaicAlt Window where
+    description _ = "MosaicAlt"
+    doLayout (MosaicAlt params) rect stack =
+            return (arrange rect stack params', Just $ MosaicAlt params')
+        where
+            params' = ins (W.up stack) $ ins (W.down stack) $ ins [W.focus stack] params
+            ins wins as = foldl M.union as $ map (`M.singleton` (Param 1 1.5)) wins
+
+    handleMessage (MosaicAlt params) msg = return $ case fromMessage msg of
+        Just (ShrinkWindowAlt w) -> Just $ MosaicAlt $ alter params w (4 % 5) 1
+        Just (ExpandWindowAlt w) -> Just $ MosaicAlt $ alter params w (6 % 5) 1
+        Just (TallWindowAlt w) -> Just $ MosaicAlt $ alter params w 1 (3 % 4)
+        Just (WideWindowAlt w) -> Just $ MosaicAlt $ alter params w 1 (5 % 4)
+        Just ResetAlt -> Just $ MosaicAlt M.empty
+        _ -> Nothing
+
+-- Change requested params for a window.
+alter :: Params -> Window -> Rational -> Rational -> Params
+alter params win arDelta asDelta = case M.lookup win params of
+    Just (Param ar as) -> M.insert win (Param (ar * arDelta) (as * asDelta)) params
+    Nothing -> M.insert win (Param arDelta (1.5 * asDelta)) params
+
+-- Layout algorithm entry point.
+arrange :: Rectangle -> W.Stack Window -> Params -> [(Window, Rectangle)]
+arrange rect stack params = r
+    where
+        (_, r) = findSplits 3 rect tree params
+        tree = makeTree (sortBy areaCompare wins) params
+        wins = reverse (W.up stack) ++ W.focus stack : W.down stack
+        areaCompare a b = or1 b `compare` or1 a
+        or1 w = maybe 1 area $ M.lookup w params
+
+-- Recursively group windows into a binary tree. Aim to balance the tree
+-- according to the total requested area in each branch.
+data Tree = Node (Rational, Tree) (Rational, Tree) | Leaf Window | None
+makeTree :: [Window] -> Params -> Tree
+makeTree wins params = case wins of
+    [] -> None
+    [x] -> Leaf x
+    _ -> Node (aArea, makeTree aWins params) (bArea, makeTree bWins params)
+        where ((aWins, aArea), (bWins, bArea)) = areaSplit params wins
+
+-- Split a list of windows in half by area.
+areaSplit :: Params -> [Window] -> (([Window], Rational), ([Window], Rational))
+areaSplit params wins = gather [] 0 [] 0 wins
+    where
+        gather a aa b ba (r : rs) =
+            if aa <= ba
+                then gather (r : a) (aa + or1 r) b ba rs
+                else gather a aa (r : b) (ba + or1 r) rs
+        gather a aa b ba [] = ((reverse a, aa), (b, ba))
+        or1 w = maybe 1 area $ M.lookup w params
+
+-- Figure out which ways to split the space, by exhaustive search.
+-- Complexity is quadratic in the number of windows.
+findSplits :: Int -> Rectangle -> Tree -> Params -> (Double, [(Window, Rectangle)])
+findSplits _ _ None _ = (0, [])
+findSplits _ rect (Leaf w) params = (aspectBadness rect w params, [(w, rect)])
+findSplits depth rect (Node (aArea, aTree) (bArea, bTree)) params =
+        if hBadness < vBadness then (hBadness, hList) else (vBadness, vList)
+    where
+        (hBadness, hList) = trySplit splitHorizontallyBy
+        (vBadness, vList) = trySplit splitVerticallyBy
+        trySplit splitBy =
+                (aBadness + bBadness, aList ++ bList)
+            where
+                (aBadness, aList) = findSplits (depth - 1) aRect aTree params
+                (bBadness, bList) = findSplits (depth - 1) bRect bTree params
+                (aRect, bRect) = splitBy ratio rect
+        ratio = aArea / (aArea + bArea)
+
+-- Decide how much we like this rectangle.
+aspectBadness :: Rectangle -> Window -> Params -> Double
+aspectBadness rect win params =
+        (if a < 1 then tall else wide) * sqrt(w * h)
+    where
+        tall = if w < 700 then ((1 / a) * (700 / w)) else 1 / a
+        wide = if w < 700 then a else (a * w / 700)
+        a = (w / h) / fromRational (maybe 1.5 aspect $ M.lookup win params)
+        w = fromIntegral $ rect_width rect
+        h = fromIntegral $ rect_height rect
+
+-- vim: sw=4:et

MouseGestures.hs

@@ -0,0 +1,116 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.MouseGestures
+-- Copyright   :  (c) Lukas Mai
+-- License     :  BSD3-style (see LICENSE)
+-- 
+-- Maintainer  :  <l.mai@web.de>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Support for simple mouse gestures
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.MouseGestures (
+    -- * Usage
+    -- $usage
+	Direction(..),
+    mouseGesture
+) where
+
+import XMonad
+import Operations
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+
+import Control.Monad.Reader
+import Data.IORef
+import qualified Data.Map as M
+import Data.Map (Map)
+
+import System.IO
+
+-- $usage
+-- In your Config.hs:
+--
+-- > import XMonadContrib.MouseGestures
+-- > ...
+-- > mouseBindings = M.fromList $
+-- >     [ ...
+-- >     , ((modMask .|. shiftMask, button3), mouseGesture gestures)
+-- >     ]
+-- >     where
+-- >     gestures = M.fromList
+-- >         [ ([], focus)
+-- >         , ([U], \w -> focus w >> windows W.swapUp)
+-- >         , ([D], \w -> focus w >> windows W.swapDown)
+-- >         , ([R, D], \_ -> sendMessage NextLayout)
+-- >         ]
+--
+-- This is just an example, of course. You can use any mouse button and
+-- gesture definitions you want.
+
+data Direction = L | U | R | D
+    deriving (Eq, Ord, Show, Read, Enum, Bounded)
+
+type Pos = (Position, Position)
+
+delta :: Pos -> Pos -> Position
+delta (ax, ay) (bx, by) = max (d ax bx) (d ay by)
+    where
+    d a b = abs (a - b)
+
+dir :: Pos -> Pos -> Direction
+dir (ax, ay) (bx, by) = trans . (/ pi) $ atan2 (fromIntegral $ ay - by) (fromIntegral $ bx - ax)
+    where
+    trans :: Double -> Direction
+    trans x
+        | rg (-3/4) (-1/4) x = D
+        | rg (-1/4)  (1/4) x = R
+        | rg  (1/4)  (3/4) x = U
+        | otherwise          = L
+    rg a z x = a <= x && x < z
+
+debugging :: Int
+debugging = 0
+
+collect :: IORef (Pos, [(Direction, Pos, Pos)]) -> Position -> Position -> X ()
+collect st nx ny = do
+    let np = (nx, ny)
+    stx@(op, ds) <- io $ readIORef st
+    when (debugging > 0) $ io $ putStrLn $ show "Mouse Gesture" ++ unwords (map show (extract stx)) ++ (if debugging > 1 then "; " ++ show op ++ "-" ++ show np else "")
+    case ds of
+        []
+            | insignificant np op -> return ()
+            | otherwise -> io $ writeIORef st (op, [(dir op np, np, op)])
+        (d, zp, ap_) : ds'
+            | insignificant np zp -> return ()
+            | otherwise -> do
+                let
+                    d' = dir zp np
+                    ds''
+                        | d == d'   = (d, np, ap_) : ds'
+                        | otherwise = (d', np, zp) : ds
+                io $ writeIORef st (op, ds'')
+    where
+    insignificant a b = delta a b < 10
+
+extract :: (Pos, [(Direction, Pos, Pos)]) -> [Direction]
+extract (_, xs) = reverse . map (\(x, _, _) -> x) $ xs
+
+mouseGesture :: Map [Direction] (Window -> X ()) -> Window -> X ()
+mouseGesture tbl win = withDisplay $ \dpy -> do
+    root <- asks theRoot
+    let win' = if win == none then root else win
+    acc <- io $ do
+        qp@(_, _, _, ix, iy, _, _, _) <- queryPointer dpy win'
+        when (debugging > 1) $ putStrLn $ show "queryPointer" ++ show qp
+        when (debugging > 1 && win' == none) $ putStrLn $ show "mouseGesture" ++ "zomg none"
+        newIORef ((fromIntegral ix, fromIntegral iy), [])
+    mouseDrag (collect acc) $ do
+        when (debugging > 0) $ io $ putStrLn $ show ""
+        gest <- io $ liftM extract $ readIORef acc
+        case M.lookup gest tbl of
+            Nothing -> return ()
+            Just f -> f win'

NoBorders.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.NoBorders
@@ -18,40 +20,80 @@
 module XMonadContrib.NoBorders (
                                 -- * Usage
                                 -- $usage
-                                noBorders, 
-                                withBorder 
+                                noBorders,
+                                smartBorders,
+                                withBorder
                                ) where
 
 import Control.Monad.State ( gets )
 import Graphics.X11.Xlib
 
 import XMonad
-import Operations ( UnDoLayout(UnDoLayout) )
-import qualified StackSet as W
+import XMonadContrib.LayoutModifier
 import {-# SOURCE #-} Config (borderWidth)
+import qualified StackSet as W
+import Data.List ((\\))
 
 -- $usage
 -- You can use this module with the following in your Config.hs file:
 --
 -- > import XMonadContrib.NoBorders
 --
--- and modify the defaultLayouts to call noBorders on the layouts you want to lack
+-- and modify the layouts to call noBorders on the layouts you want to lack
 -- borders
 --
--- > defaultLayouts = [ noBorders full, ... ]
+-- > layouts = [ Layout (noBorders Full), ... ]
 
-noBorders :: Layout a -> Layout a
-noBorders = withBorder 0
+-- %import XMonadContrib.NoBorders
+-- %layout -- prepend noBorders to default layouts above to remove their borders, like so:
+-- %layout , noBorders Full
 
-withBorder :: Dimension -> Layout a -> Layout a
-withBorder bd l = l { doLayout = \r x -> setborders bd >> doLayout l r x
-                    , modifyLayout = ml }
-    where ml m | Just UnDoLayout == fromMessage m
-                   = do setborders borderWidth
-                        fmap (withBorder bd) `fmap` (modifyLayout l) m
-               | otherwise = fmap (withBorder bd) `fmap` (modifyLayout l) m
+-- todo, use an InvisibleList.
+data WithBorder a = WithBorder Dimension [a] deriving ( Read, Show )
 
-setborders :: Dimension -> X ()
-setborders bw = withDisplay $ \d ->
-                do ws <- gets (W.integrate' . W.stack . W.workspace . W.current . windowset)
-                   mapM_ (\w -> io $ setWindowBorderWidth d w bw) ws
+instance LayoutModifier WithBorder Window where
+    modifierDescription (WithBorder 0 _) = "NoBorders"
+    modifierDescription (WithBorder n _) = "Borders " ++ show n
+
+    unhook (WithBorder _ s) = setBorders borderWidth s
+
+    redoLayout (WithBorder n s) _ _ wrs = do
+        setBorders borderWidth (s \\ ws)
+        setBorders n ws
+        return (wrs, Just $ WithBorder n ws)
+     where
+        ws = map fst wrs
+
+noBorders :: LayoutClass l Window => l Window -> ModifiedLayout WithBorder l Window
+noBorders = ModifiedLayout $ WithBorder 0 []
+
+withBorder :: LayoutClass l a => Dimension -> l a -> ModifiedLayout WithBorder l a
+withBorder b = ModifiedLayout $ WithBorder b []
+
+setBorders :: Dimension -> [Window] -> X ()
+setBorders bw ws = withDisplay $ \d -> mapM_ (\w -> io $ setWindowBorderWidth d w bw) ws
+
+data SmartBorder a = SmartBorder [a] deriving (Read, Show)
+
+instance LayoutModifier SmartBorder Window where
+    modifierDescription _ = "SmartBorder"
+
+    unhook (SmartBorder s) = setBorders borderWidth s
+
+    redoLayout (SmartBorder s) _ _ wrs = do
+        ss <- gets (W.screens . windowset)
+
+        if singleton ws && singleton ss
+            then do
+                setBorders borderWidth (s \\ ws)
+                setBorders 0 ws
+                return (wrs, Just $ SmartBorder ws)
+            else do
+                setBorders borderWidth s
+                return (wrs, Just $ SmartBorder [])
+     where
+        ws = map fst wrs
+        singleton = null . drop 1
+
+smartBorders :: LayoutClass l a => l a -> ModifiedLayout SmartBorder l a
+smartBorders = ModifiedLayout (SmartBorder [])

ResizableTile.hs

@@ -0,0 +1,93 @@
+{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable
+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.ResizableTile
+-- Copyright   :  (c) MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com>
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- More useful tiled layout that allows you to change a width\/height of window.
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.ResizableTile (
+                                    -- * Usage
+                                    -- $usage
+                                    ResizableTall(..), MirrorResize(..)
+                                   ) where
+
+import XMonad
+import Operations (Resize(..), IncMasterN(..))
+import qualified StackSet as W
+import Graphics.X11.Xlib
+import Control.Monad.State
+import Control.Monad
+
+-- $usage
+--
+-- To use, modify your Config.hs to:
+--
+-- >    import XMonadContrib.ResizableTile
+--
+-- and add a keybinding:
+--
+-- >    , ((modMask,               xK_a     ), sendMessage MirrorShrink)
+-- >    , ((modMask,               xK_z     ), sendMessage MirrorExpand)
+--
+-- and redefine "tiled" as:
+--
+-- >     tiled   = ResizableTall nmaster delta ratio []
+
+data MirrorResize = MirrorShrink | MirrorExpand deriving Typeable
+instance Message MirrorResize
+
+data ResizableTall a = ResizableTall Int Rational Rational [Rational] deriving (Show, Read)
+instance LayoutClass ResizableTall a where
+    doLayout (ResizableTall nmaster _ frac mfrac) r =
+        return . (\x->(x,Nothing)) .
+        ap zip (tile frac (mfrac ++ repeat 1) r nmaster . length) . W.integrate
+    handleMessage (ResizableTall nmaster delta frac mfrac) m =
+        do ms <- (W.stack . W.workspace . W.current) `fmap` gets windowset
+           case ms of
+             Nothing -> return Nothing
+             Just s -> return $ msum [fmap resize (fromMessage m)
+                                     ,fmap (\x -> mresize x s) (fromMessage m)
+                                     ,fmap incmastern (fromMessage m)]
+        where resize Shrink = ResizableTall nmaster delta (max 0 $ frac-delta) mfrac
+              resize Expand = ResizableTall nmaster delta (min 1 $ frac+delta) mfrac
+              mresize MirrorShrink s = mresize' s delta
+              mresize MirrorExpand s = mresize' s (0-delta)
+              mresize' s d = let n = length $ W.up s
+                                 total = n + (length $ W.down s) + 1
+                                 pos = if n == (nmaster-1) || n == (total-1) then n-1 else n
+                                 mfrac' = modifymfrac (mfrac ++ repeat 1) d pos
+                             in ResizableTall nmaster delta frac $ take total mfrac'
+              modifymfrac [] _ _ = []
+              modifymfrac (f:fx) d n | n == 0    = f+d : fx
+                                     | otherwise = f : modifymfrac fx d (n-1)
+              incmastern (IncMasterN d) = ResizableTall (max 0 (nmaster+d)) delta frac mfrac
+    description _ = "ResizableTall"
+
+tile :: Rational -> [Rational] -> Rectangle -> Int -> Int -> [Rectangle]
+tile f mf r nmaster n = if n <= nmaster || nmaster == 0
+    then splitVertically mf n r
+    else splitVertically mf nmaster r1 ++ splitVertically (drop nmaster mf) (n-nmaster) r2 -- two columns
+  where (r1,r2) = splitHorizontallyBy f r
+
+splitVertically :: RealFrac r => [r] -> Int -> Rectangle -> [Rectangle]
+splitVertically [] _ r = [r]
+splitVertically _ n r | n < 2 = [r]
+splitVertically (f:fx) n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh :
+    splitVertically fx (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh))
+  where smallh = floor $ fromIntegral (sh `div` fromIntegral n) * f --hmm, this is a fold or map.
+
+splitHorizontallyBy :: RealFrac r => r -> Rectangle -> (Rectangle, Rectangle)
+splitHorizontallyBy f (Rectangle sx sy sw sh) =
+    ( Rectangle sx sy leftw sh
+    , Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh)
+  where leftw = floor $ fromIntegral sw * f

Roledex.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.Roledex
@@ -10,30 +12,34 @@
 --
 -- Screenshot  :  <http://www.timthelion.com/rolodex.png>
 --
--- This is a compleatly pointless layout which acts like Microsoft's Flip 3D
+-- This is a completely pointless layout which acts like Microsoft's Flip 3D
 -----------------------------------------------------------------------------
 
 module XMonadContrib.Roledex (
     -- * Usage
     -- $usage
-    roledex) where
+    Roledex(Roledex)) where
 
 import XMonad
 import Operations
 import qualified StackSet as W
 import Graphics.X11.Xlib
 import Data.Ratio
-import XMonadContrib.LayoutHelpers ( idModify )
 
 -- $usage
 --
 -- > import XMonadContrib.Roledex 
--- > defaultLayouts = [ roledex ]
+-- > layouts = [ Layout Roledex ]
 
-roledex :: Eq a => Layout a
-roledex = Layout { doLayout = roledexLayout, modifyLayout = idModify }
+-- %import XMonadContrib.Roledex
+-- %layout , Layout Roledex
 
-roledexLayout :: Eq a => Rectangle -> W.Stack a -> X ([(a, Rectangle)], Maybe (Layout a))
+data Roledex a = Roledex deriving ( Show, Read )
+
+instance LayoutClass Roledex Window where
+    doLayout _ = roledexLayout
+
+roledexLayout :: Eq a => Rectangle -> W.Stack a -> X ([(a, Rectangle)], Maybe (Roledex a))
 roledexLayout sc ws = return ([(W.focus ws, mainPane)] ++
                               (zip ups tops) ++
                               (reverse (zip dns bottoms))
@@ -41,7 +47,7 @@ roledexLayout sc ws = return ([(W.focus ws, mainPane)] ++
  where ups    = W.up ws
        dns    = W.down ws
        c = length ups + length dns
-       rect = fst $ splitHorizontallyBy (2% 3) $ fst (splitVerticallyBy (2% 3) sc) 
+       rect = fst $ splitHorizontallyBy (2%3 :: Ratio Int) $ fst (splitVerticallyBy (2%3 :: Ratio Int) sc) 
        gw = div' (w - rw) (fromIntegral c) 
             where
             (Rectangle _ _ w _) = sc
@@ -59,5 +65,6 @@ roledexLayout sc ws = return ([(W.focus ws, mainPane)] ++
                 then (n - 1) : (cd (n-1) m)
                 else []
 
+div' :: Integral a => a -> a -> a
 div' _ 0 = 0
 div' n o = div n o

RotSlaves.hs

@@ -32,7 +32,10 @@ import XMonad
 --
 --
 -- This operation will rotate all windows except the master window, while the focus
--- stays where it is. It is usefull together with the TwoPane-Layout (see XMonadContrib.TwoPane).
+-- stays where it is. It is useful together with the TwoPane-Layout (see XMonadContrib.TwoPane).
+
+-- %import XMonadContrib.RotSlaves
+-- %keybind , ((modMask .|. shiftMask, xK_Tab   ), rotSlavesUp)
 
 rotSlavesUp,rotSlavesDown :: X ()
 rotSlavesUp   = windows $ modify' (rotSlaves' (\l -> (tail l)++[head l]))

RotView.hs

@@ -19,27 +19,35 @@ module XMonadContrib.RotView (
                              ) where
 
 import Control.Monad.State ( gets )
-import Data.List ( sortBy )
-import Data.Maybe ( listToMaybe, isJust )
+import Data.List ( sortBy, find )
+import Data.Maybe ( isJust )
 import Data.Ord ( comparing )
 
 import XMonad
 import StackSet hiding (filter)
-import qualified Operations as O
+import Operations
 
 -- $usage
 -- You can use this module with the following in your Config.hs file:
--- 
+--
 -- > import XMonadContrib.RotView
 --
 -- >   , ((modMask .|. shiftMask, xK_Right), rotView True)
 -- >   , ((modMask .|. shiftMask, xK_Left), rotView False)
 
+-- %import XMonadContrib.RotView
+-- %keybind , ((modMask .|. shiftMask, xK_Right), rotView True)
+-- %keybind , ((modMask .|. shiftMask, xK_Left), rotView False)
+
 rotView :: Bool -> X ()
-rotView b = do
+rotView forward = do
     ws <- gets windowset
-    let m = tag . workspace . current $ ws
-        sortWs = sortBy (comparing tag)
-        pivoted = uncurry (flip (++)) . span ((< m) . tag) . sortWs . hidden $ ws
-        nextws = listToMaybe . filter (isJust . stack) . (if b then id else reverse) $ pivoted
-    whenJust nextws (O.view . tag)
+    let currentTag = tag . workspace . current $ ws
+        sortWs     = sortBy (comparing tag)
+        isNotEmpty = isJust . stack
+        sorted     = sortWs (hidden ws)
+        pivoted    = let (a,b) = span ((< currentTag) . tag) sorted in b ++ a
+        pivoted'   | forward   = pivoted
+                   | otherwise = reverse pivoted
+        nextws     = find isNotEmpty pivoted'
+    whenJust nextws (windows . view . tag)

SetWMName.hs

@@ -0,0 +1,114 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.SetWMName
+-- Copyright   :  © 2007 Ivan Tarasov <Ivan.Tarasov@gmail.com>
+-- License     :  BSD
+--
+-- Maintainer  :  Ivan.Tarasov@gmail.com
+-- Stability   :  experimental
+-- Portability :  unportable
+--
+-- Sets the WM name to a given string, so that it could be detected using
+-- _NET_SUPPORTING_WM_CHECK protocol.
+--
+-- May be useful for making Java GUI programs work, just set WM name to "LG3D"
+-- and use Java 1.6u1 (1.6.0_01-ea-b03 works for me) or later.
+--
+-- Remember that you need to call the setWMName action yourself (at least until
+-- we have startup hooks). E.g., you can bind it in your Config.hs:
+--
+-- > ((modMask .|. controlMask .|. shiftMask, xK_z), setWMName "LG3D") -- @@ Java hack
+--
+-- and press the key combination before running the Java programs (you only
+-- need to do it once per XMonad execution)
+--
+-- For details on the problems with running Java GUI programs in non-reparenting
+-- WMs, see "http:\/\/bugs.sun.com\/bugdatabase\/view_bug.do?bug_id=6429775" and
+-- related bugs.
+--
+-- Setting WM name to "compiz" does not solve the problem, because of yet
+-- another bug in AWT code (related to insets). For LG3D insets are explicitly
+-- set to 0, while for other WMs the insets are \"guessed\" and the algorithm
+-- fails miserably by guessing absolutely bogus values.
+-----------------------------------------------------------------------------
+
+module XMonadContrib.SetWMName (
+    setWMName) where
+
+import Control.Monad (join)
+import Control.Monad.Reader (asks)
+import Data.Bits ((.|.))
+import Data.Char (ord)
+import Data.List (nub)
+import Data.Maybe (fromJust, listToMaybe, maybeToList)
+import Data.Word (Word8)
+
+import Foreign.Marshal.Alloc (alloca)
+
+import XMonad
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Atom
+import Graphics.X11.Xlib.Extras
+
+-- | sets WM name
+setWMName :: String -> X ()
+setWMName name = do
+    atom_NET_SUPPORTING_WM_CHECK <- netSupportingWMCheckAtom
+    atom_NET_WM_NAME <- getAtom "_NET_WM_NAME"
+    atom_NET_SUPPORTED_ATOM <- getAtom "_NET_SUPPORTED"
+    atom_UTF8_STRING <- getAtom "UTF8_STRING"
+
+    root <- asks theRoot
+    supportWindow <- getSupportWindow
+    dpy <- asks display
+    io $ do
+        -- _NET_SUPPORTING_WM_CHECK atom of root and support windows refers to the support window
+        mapM_ (\w -> changeProperty32 dpy w atom_NET_SUPPORTING_WM_CHECK wINDOW 0 [fromIntegral supportWindow]) [root, supportWindow]
+        -- set WM_NAME in supportWindow (now only accepts latin1 names to eliminate dependency on utf8 encoder)
+        changeProperty8 dpy supportWindow atom_NET_WM_NAME atom_UTF8_STRING 0 (latin1StringToWord8List name)
+        -- declare which _NET protocols are supported (append to the list if it exists)
+        supportedList <- fmap (join . maybeToList) $ getWindowProperty32 dpy atom_NET_SUPPORTED_ATOM root
+        changeProperty32 dpy root atom_NET_SUPPORTED_ATOM aTOM 0 (nub $ fromIntegral atom_NET_SUPPORTING_WM_CHECK : fromIntegral atom_NET_WM_NAME : supportedList)
+  where
+    netSupportingWMCheckAtom :: X Atom
+    netSupportingWMCheckAtom = getAtom "_NET_SUPPORTING_WM_CHECK"
+
+    latin1StringToWord8List :: String -> [Word8]
+    latin1StringToWord8List str = map (fromIntegral . ord) str
+
+    getSupportWindow :: X Window
+    getSupportWindow = withDisplay $ \dpy -> do
+        atom_NET_SUPPORTING_WM_CHECK <- netSupportingWMCheckAtom
+        root <- asks theRoot
+        supportWindow <- fmap (join . fmap listToMaybe) $ io $ getWindowProperty32 dpy atom_NET_SUPPORTING_WM_CHECK root
+        validateWindow (fmap fromIntegral supportWindow)
+
+    validateWindow :: Maybe Window -> X Window
+    validateWindow w = do
+        valid <- maybe (return False) isValidWindow w
+        if valid then
+            return $ fromJust w
+          else
+            createSupportWindow
+
+    -- is there a better way to check the validity of the window?
+    isValidWindow :: Window -> X Bool
+    isValidWindow w = withDisplay $ \dpy -> io $ alloca $ \p -> do
+        status <- xGetWindowAttributes dpy w p
+        return (status /= 0)
+
+    -- this code was translated from C (see OpenBox WM, screen.c)
+    createSupportWindow :: X Window
+    createSupportWindow = withDisplay $ \dpy -> do
+        root <- asks theRoot
+        let visual = defaultVisual dpy (defaultScreen dpy)  -- should be CopyFromParent (=0), but the constructor is hidden in X11.XLib
+        window <- io $ allocaSetWindowAttributes $ \winAttrs -> do
+            set_override_redirect winAttrs True         -- WM cannot decorate/move/close this window
+            set_event_mask winAttrs propertyChangeMask  -- not sure if this is needed
+            let bogusX = -100
+                bogusY = -100
+              in
+                createWindow dpy root bogusX bogusY 1 1 0 0 inputOutput visual (cWEventMask .|. cWOverrideRedirect) winAttrs
+        io $ mapWindow dpy window   -- not sure if this is needed
+        io $ lowerWindow dpy window -- not sure if this is needed
+        return window

ShellPrompt.hs

@@ -3,7 +3,7 @@
 -- Module      :  XMonadContrib.ShellPrompt
 -- Copyright   :  (C) 2007 Andrea Rossato
 -- License     :  BSD3
--- 
+--
 -- Maintainer  :  andrea.rossato@unibz.it
 -- Stability   :  unstable
 -- Portability :  unportable
@@ -16,76 +16,94 @@ module XMonadContrib.ShellPrompt (
                              -- * Usage
                              -- $usage
                              shellPrompt
-                             , rmPath
+                             , getShellCompl
                              , split
                               ) where
 
 import XMonad
 import XMonadContrib.XPrompt
+import XMonadContrib.Dmenu
 
 import Control.Monad
 import Data.List
-import System.Console.Readline
+import Data.Set (toList, fromList)
+import System.Directory
+import System.IO
 import System.Environment
 
 -- $usage
 --
--- 1. In xmonad.cabal change: 
---
--- > build-depends:      base>=2.0, X11>=1.2.1, X11-extras>=0.2, mtl>=1.0, unix>=1.0
---
--- to
---
--- > build-depends:      base>=2.0, X11>=1.2.1, X11-extras>=0.2, mtl>=1.0, unix>=1.0, readline >= 1.0
---
--- 2. In Config.hs add:
+-- 1. In Config.hs add:
 --
 -- > import XMonadContrib.XPrompt
 -- > import XMonadContrib.ShellPrompt
 --
--- 3. In your keybindings add something like:
+-- 2. In your keybindings add something like:
 --
 -- >   , ((modMask .|. controlMask, xK_x), shellPrompt defaultXPConfig)
 --
 
+-- %import XMonadContrib.XPrompt
+-- %import XMonadContrib.ShellPrompt
+-- %keybind , ((modMask .|. controlMask, xK_x), shellPrompt defaultXPConfig)
+
 data Shell = Shell
 
 instance XPrompt Shell where
     showXPrompt Shell = "Run:   "
 
-
 shellPrompt :: XPConfig -> X ()
-shellPrompt c = mkXPrompt Shell c getShellCompl spawn
+shellPrompt c = do
+    cmds <- io $ getCommands
+    mkXPrompt Shell c (getShellCompl cmds) spawn
 
-getShellCompl :: String -> IO [String]
-getShellCompl s 
-    | s /= "" && last s /= ' ' = do
-  fl <- filenameCompletionFunction s
-  c <- commandCompletionFunction s
-  return $ sort . nub $ fl ++ c
-    | otherwise = return []
+getShellCompl :: [String] -> String -> IO [String]
+getShellCompl cmds s | s == "" || last s == ' ' = return []
+                     | otherwise                = do
+    f <- fmap lines $ runProcessWithInput "/bin/bash" [] ("compgen -A file " ++ s ++ "\n")
+    return . map escape . uniqSort $ f ++ commandCompletionFunction cmds s
 
-commandCompletionFunction :: String -> IO [String]
-commandCompletionFunction str 
-    | '/' `elem` str = return []
-    | otherwise = do
-  p <- getEnv "PATH"
-  cl p
-    where
-      cl = liftM (nub . rmPath . concat) . mapM fCF . map addToPath . split ':'  
-      addToPath = flip (++) ("/" ++ str)
-      fCF = filenameCompletionFunction
+uniqSort :: Ord a => [a] -> [a]
+uniqSort = toList . fromList
 
-rmPath :: [String] -> [String]
-rmPath s = 
-    map (reverse . fst . break  (=='/') . reverse) s
+commandCompletionFunction :: [String] -> String -> [String]
+commandCompletionFunction cmds str | '/' `elem` str = []
+                                   | otherwise      = filter (isPrefixOf str) cmds
+
+getCommands :: IO [String]
+getCommands = do
+    p  <- getEnv "PATH" `catch` const (return [])
+    let ds = split ':' p
+        fp d f = d ++ "/" ++ f
+    es <- forM ds $ \d -> do
+        exists <- doesDirectoryExist d
+        if exists
+            then getDirectoryContents d >>= filterM (isExecutable . fp d)
+            else return []
+    return . uniqSort . concat $ es
+
+isExecutable :: FilePath ->IO Bool
+isExecutable f = do
+    fe <- doesFileExist f
+    if fe
+        then fmap executable $ getPermissions f
+        else return False
 
 split :: Eq a => a -> [a] -> [[a]]
 split _ [] = []
 split e l =
     f : split e (rest ls)
-        where 
+        where
           (f,ls) = span (/=e) l
-          rest s | s == [] = []
+          rest s | s == []   = []
                  | otherwise = tail s
 
+escape :: String -> String
+escape []       = ""
+escape (' ':xs) = "\\ " ++ escape xs
+escape (x:xs)
+    | isSpecialChar x = '\\' : x : escape xs
+    | otherwise       = x : escape xs
+
+isSpecialChar :: Char -> Bool
+isSpecialChar =  flip elem "\\@\"'#?$*()[]{};"

SimpleDate.hs

@@ -32,5 +32,8 @@ import XMonad
 --
 -- a popup date menu will now be bound to mod-d
 
+-- %import XMonadContrib.SimpleDate
+-- %keybind , ((modMask,               xK_d     ), date)
+
 date :: X ()
 date = spawn "(date; sleep 10) | dzen2"

SimpleStacking.hs

@@ -1,44 +0,0 @@
-{-# OPTIONS -fglasgow-exts #-}
------------------------------------------------------------------------------
--- |
--- Module      :  XMonadContrib.SimpleStacking
--- Copyright   :  (c) David Roundy <droundy@darcs.net>
--- License     :  BSD-style (see LICENSE)
--- 
--- Maintainer  :  David Roundy <droundy@darcs.net>
--- Stability   :  unstable
--- Portability :  unportable
---
--- A module to be used to obtain a simple "memory" of stacking order.
---
------------------------------------------------------------------------------
-
-module XMonadContrib.SimpleStacking (
-                                     -- * Usage
-                                     -- $usage 
-                                     simpleStacking
-                                    ) where
-
-import Data.Maybe ( catMaybes )
-
-import Data.List ( nub, lookup )
-import StackSet ( focus, up, down )
-import Graphics.X11.Xlib ( Window )
-
-import XMonad
-import XMonadContrib.LayoutHelpers
-
--- $usage
--- You can use this module for 
--- See, for instance, "XMonadContrib.Tabbed"
-
-simpleStacking :: Layout Window -> Layout Window
-simpleStacking = simpleStacking' []
-
-simpleStacking' :: [Window] -> Layout Window -> Layout Window
-simpleStacking' st = layoutModify dl idModMod
-    where dl _ 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'))

SinkAll.hs

@@ -16,19 +16,21 @@ module XMonadContrib.SinkAll (
 
 import Operations
 import XMonad
-import StackSet hiding (sink)
+import StackSet
 
-import Control.Monad.State
 import Graphics.X11.Xlib
 
 -- $usage
 -- > import XMonadContrib.SinkAll
 -- > keys = [ ((modMask .|. shiftMask, xK_t), sinkAll) ]
 
+-- %import XMonadContrib.SinkAll
+-- %keybind , ((modMask .|. shiftMask, xK_t), sinkAll)
+
 sinkAll :: X ()
 sinkAll = withAll sink
 
 -- Apply a function to all windows on current workspace.
-withAll :: (Window -> X a) -> X ()
-withAll f = gets (integrate' . stack . workspace . current . windowset) >>=
-    mapM_ f
+withAll :: (Window -> WindowSet -> WindowSet) -> X ()
+withAll f = windows $ \ws -> let all' = integrate' . stack . workspace . current $ ws
+                             in foldr f ws all'

Spiral.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.Spiral
@@ -25,19 +27,17 @@ import Graphics.X11.Xlib
 import Operations
 import Data.Ratio
 import XMonad
-
-import XMonadContrib.LayoutHelpers
+import StackSet ( integrate )
 
 -- $usage
 -- You can use this module with the following in your Config.hs file:
 --
 -- >   import XMonadContrib.Spiral
 --
--- >   defaultLayouts :: [Layout]
--- >   defaultLayouts = [ full,
--- >                      tall defaultWindowsInMaster defaultDelta (1%2),
--- >                      wide defaultWindowsInMaster defaultDelta (1%2),
--- >                      spiral (1 % 1) ]
+-- >   layouts = [ ..., Layout $ spiral (1 % 1), ... ]
+
+-- %import XMonadContrib.Spiral
+-- %layout , Layout $ spiral (1 % 1)
 
 fibs :: [Integer]
 fibs = 1 : 1 : (zipWith (+) fibs (tail fibs))
@@ -46,8 +46,8 @@ mkRatios :: [Integer] -> [Rational]
 mkRatios (x1:x2:xs) = (x1 % x2) : mkRatios (x2:xs)
 mkRatios _ = []
 
-data Rotation = CW | CCW
-data Direction = East | South | West | North deriving (Eq, Enum)
+data Rotation = CW | CCW deriving (Read, Show)
+data Direction = East | South | West | North deriving (Eq, Enum, Read, Show)
 
 blend :: Rational -> [Rational] -> [Rational]
 blend scale ratios = zipWith (+) ratios scaleFactors
@@ -56,21 +56,27 @@ blend scale ratios = zipWith (+) ratios scaleFactors
       step = (scale - (1 % 1)) / (fromIntegral len)
       scaleFactors = map (* step) . reverse . take len $ [0..]
 
-spiral :: Rational -> Layout a
+spiral :: Rational -> SpiralWithDir a
 spiral = spiralWithDir East CW
 
-spiralWithDir :: Direction -> Rotation -> Rational -> Layout a
-spiralWithDir dir rot scale = Layout { doLayout = l2lModDo fibLayout,
-                                       modifyLayout = \m -> return $ fmap resize $ fromMessage m }
-    where
-      fibLayout sc ws = zip ws rects
-          where ratios = blend scale . reverse . take (length ws - 1) . mkRatios $ tail fibs
-                rects = divideRects (zip ratios dirs) sc
-                dirs  = dropWhile (/= dir) $ case rot of
-                                               CW  -> cycle [East .. North] 
-                                               CCW -> cycle [North, West, South, East]
-      resize Expand = spiralWithDir dir rot $ (21 % 20) * scale
-      resize Shrink = spiralWithDir dir rot $ (20 % 21) * scale
+spiralWithDir :: Direction -> Rotation -> Rational -> SpiralWithDir a
+spiralWithDir = SpiralWithDir
+
+data SpiralWithDir a = SpiralWithDir Direction Rotation Rational
+                     deriving ( Read, Show )
+
+instance LayoutClass SpiralWithDir a where
+    pureLayout (SpiralWithDir dir rot scale) sc stack = zip ws rects
+        where ws = integrate stack
+              ratios = blend scale . reverse . take (length ws - 1) . mkRatios $ tail fibs
+              rects = divideRects (zip ratios dirs) sc
+              dirs  = dropWhile (/= dir) $ case rot of
+                                           CW  -> cycle [East .. North] 
+                                           CCW -> cycle [North, West, South, East]
+    handleMessage (SpiralWithDir dir rot scale) = return . fmap resize . fromMessage
+        where resize Expand = spiralWithDir dir rot $ (21 % 20) * scale
+              resize Shrink = spiralWithDir dir rot $ (20 % 21) * scale
+    description _ = "Spiral"
 
 -- This will produce one more rectangle than there are splits details
 divideRects :: [(Rational, Direction)] -> Rectangle -> [Rectangle]

Square.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.Square
@@ -20,11 +22,11 @@
 module XMonadContrib.Square (
                              -- * Usage
                              -- $usage
-                             square ) where
+                             Square(..) ) where
 
 import XMonad
 import Graphics.X11.Xlib
-import XMonadContrib.LayoutHelpers ( l2lModDo, idModify )
+import StackSet ( integrate )
 
 -- $usage
 -- You can use this module with the following in your Config.hs file:
@@ -38,12 +40,15 @@ import XMonadContrib.LayoutHelpers ( l2lModDo, idModify )
 -- >                [(twoPane 0.03 0.2,1),(combo [(twoPane 0.03 0.8,1),(square,1)]
 -- >         [(tabbed,3),(tabbed,30),(tabbed,1),(tabbed,1)]
 
-square :: Layout a
-square = Layout { doLayout = l2lModDo arrange, modifyLayout = idModify }
- where arrange :: Rectangle -> [a] -> [(a, Rectangle)]
-       arrange rect ws@(_:_) = map (\w->(w,rest)) (init ws) ++ [(last ws,sq)]
-                 where (rest, sq) = splitSquare rect
-       arrange _ [] = []
+-- %import XMonadContrib.Square
+
+data Square a = Square deriving ( Read, Show )
+
+instance LayoutClass Square a where
+    pureLayout Square r s = arrange (integrate s)
+        where arrange ws@(_:_) = map (\w->(w,rest)) (init ws) ++ [(last ws,sq)]
+              arrange [] = [] -- actually, this is an impossible case
+              (rest, sq) = splitSquare r
 
 splitSquare :: Rectangle -> (Rectangle, Rectangle)
 splitSquare (Rectangle x y w h)

SshPrompt.hs

@@ -25,6 +25,8 @@ import XMonadContrib.RunInXTerm
 import Control.Monad
 import System.Directory
 import System.Environment
+import Data.List
+import Data.Maybe
 
 -- $usage
 -- 1. In Config.hs add:
@@ -34,9 +36,13 @@ import System.Environment
 --
 -- 3. In your keybindings add something like:
 --
--- >   , ((modMask .|. controlMask, xK_x), xmonadPrompt defaultXPConfig)
+-- >   , ((modMask .|. controlMask, xK_s), sshPrompt defaultXPConfig)
 --
 
+-- %import XMonadContrib.XPrompt
+-- %import XMonadContrib.SshPrompt
+-- %keybind , ((modMask .|. controlMask, xK_s), sshPrompt defaultXPConfig)
+
 data Ssh = Ssh
 
 instance XPrompt Ssh where
@@ -49,12 +55,49 @@ sshPrompt c = do
 
 ssh :: String -> X ()
 ssh s = runInXTerm ("ssh " ++ s)
- 
+
 sshComplList :: IO [String]
-sshComplList = do
+sshComplList =  (nub . sort) `fmap` liftM2 (++) sshComplListLocal sshComplListGlobal 
+
+sshComplListLocal :: IO [String]
+sshComplListLocal = do
   h <- getEnv "HOME"
-  let kh = h ++ "/.ssh/known_hosts"
+  sshComplListFile $ h ++ "/.ssh/known_hosts"
+ 
+sshComplListGlobal :: IO [String]
+sshComplListGlobal = do
+  env <- getEnv "SSH_KNOWN_HOSTS" `catch` (\_ -> return "/nonexistent")
+  fs <- mapM fileExists [ env
+                        , "/usr/local/etc/ssh/ssh_known_hosts"
+                        , "/usr/local/etc/ssh_known_hosts"
+                        , "/etc/ssh/ssh_known_hosts"
+                        , "/etc/ssh_known_hosts"
+                        ]
+  case catMaybes fs of
+    []    -> return []
+    (f:_) -> sshComplListFile' f
+
+sshComplListFile :: String -> IO [String]
+sshComplListFile kh = do
   f <- doesFileExist kh
-  if f then do l <- readFile kh
-               return $ map (takeWhile (/= ',') . concat . take 1 . words) (lines l)
+  if f then sshComplListFile' kh
        else return []
+
+sshComplListFile' :: String -> IO [String]
+sshComplListFile' kh = do
+  l <- readFile kh
+  return $ map (takeWhile (/= ',') . concat . take 1 . words)
+         $ filter nonComment
+         $ lines l
+
+fileExists :: String -> IO (Maybe String)
+fileExists kh = do
+  f <- doesFileExist kh
+  if f then return $ Just kh
+       else return Nothing
+
+nonComment :: String -> Bool
+nonComment []      = False
+nonComment ('#':_) = False
+nonComment ('|':_) = False -- hashed, undecodeable
+nonComment _       = True

Submap.hs

@@ -43,6 +43,14 @@ anyModifier will not work, because that is a special value passed to XGrabKey()
 and not an actual modifier.
 -}
 
+-- %import XMonadContrib.Submap
+-- %keybind , ((modMask, xK_a), submap . M.fromList $
+-- %keybind     [ ((0, xK_n),     spawn "mpc next")
+-- %keybind     , ((0, xK_p),     spawn "mpc prev")
+-- %keybind     , ((0, xK_z),     spawn "mpc random")
+-- %keybind     , ((0, xK_space), spawn "mpc toggle")
+-- %keybind     ])
+
 submap :: M.Map (KeyMask, KeySym) (X ()) -> X ()
 submap keys = do
     XConf { theRoot = root, display = d } <- ask

SwapWorkspaces.hs

@@ -0,0 +1,55 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.SwapWorkspaces
+-- Copyright   :  (c) Devin Mullins <me@twifkak.com>
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  Devin Mullins <me@twifkak.com>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Lets you swap workspace tags, so you can keep related ones next to
+-- each other, without having to move individual windows.
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.SwapWorkspaces (
+                                     -- * Usage
+                                     -- $usage
+                                     swapWithCurrent,
+                                     swapWorkspaces
+                                    ) where
+
+import StackSet
+
+-- $usage
+-- Add this import to your Config.hs:
+--
+-- > import XMonadContrib.SwapWorkspaces
+--
+-- Throw this in your keys definition:
+--
+-- > ++
+-- > [((modMask .|. controlMask, k), windows $ swapWithCurrent i)
+-- >     | (i, k) <- zip workspaces [xK_1 ..]]
+
+-- %import XMonadContrib.SwapWorkspaces
+-- %keybindlist ++
+-- %keybindlist [((modMask .|. controlMask, k), windows $ swapWithCurrent i)
+-- %keybindlist     | (i, k) <- zip workspaces [xK_1 ..]]
+--
+-- After installing this update, if you're on workspace 1, hitting mod-ctrl-5
+-- will swap workspaces 1 and 5.
+
+-- | Swaps the currently focused workspace with the given workspace tag, via
+--   @swapWorkspaces@.
+swapWithCurrent :: Eq i => i -> StackSet i l a s sd -> StackSet i l a s sd
+swapWithCurrent t s = swapWorkspaces t (tag $ workspace $ current s) s
+
+-- | Takes two workspace tags and an existing StackSet and returns a new
+--   one with the two corresponding workspaces' tags swapped.
+swapWorkspaces :: Eq i => i -> i -> StackSet i l a s sd -> StackSet i l a s sd
+swapWorkspaces t1 t2 = mapWorkspace swap
+    where swap w = if      tag w == t1 then w { tag = t2 }
+                   else if tag w == t2 then w { tag = t1 }
+                   else w

SwitchTrans.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fglasgow-exts #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.SwitchTrans
@@ -19,19 +20,26 @@
 -- 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.
+-- 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.
+--
+-- Another potential problem is that functions can't be (de-)serialized so this
+-- layout will not preserve state across xmonad restarts.
 --
 -- Here's how you might use this in Config.hs:
 --
--- > defaultLayouts =
+-- > layouts =
 -- >     map (
--- >         mkSwitch (M.singleton "full" (const $ noBorders full)) .
--- >         mkSwitch (M.singleton "mirror" mirror)
--- >     ) [ tiled ]
+-- >         mkSwitch (M.fromList [
+-- >             ("full", const $ Layout $ noBorders Full)
+-- >         ]) .
+-- >         mkSwitch (M.fromList [
+-- >             ("mirror", Layout . Mirror)
+-- >         ])
+-- >     ) [ Layout tiled ]
 --
--- (The noBorders transformer is from "XMonadContrib.NoBorders".)
+-- (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
@@ -50,13 +58,14 @@
 -- 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.
+-- The reason I use two stacked @SwitchTrans@ transformers instead of @mkSwitch
+-- (M.fromList [(\"full\", const $ Layout $ noBorders Full), (\"mirror\",
+-- Layout . 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 (
@@ -72,6 +81,9 @@ import Operations
 import qualified Data.Map as M
 import Data.Map (Map)
 
+--import System.IO
+
+
 -- | Toggle the specified layout transformer.
 data Toggle = Toggle String deriving (Eq, Typeable)
 instance Message Toggle
@@ -82,7 +94,7 @@ instance Message Enable
 data Disable = Disable String deriving (Eq, Typeable)
 instance Message Disable
 
-data State a = State {
+data SwitchTrans a = SwitchTrans {
     base :: Layout a,
     currTag :: Maybe String,
     currLayout :: Layout a,
@@ -90,12 +102,85 @@ data State a = State {
     filters :: Map String (Layout a -> Layout a)
 }
 
+instance Show (SwitchTrans a) where
+    show st = "SwitchTrans #<base: " ++ show (base st) ++ ", tag: " ++ show (currTag st) ++ ", layout: " ++ show (currLayout st) ++ ", ...>"
+
+instance Read (SwitchTrans a) where
+    readsPrec _ _ = []
+
+unLayout :: Layout a -> (forall l. (LayoutClass l a) => l a -> r) -> r
+unLayout (Layout l) k = k l
+
+acceptChange :: (LayoutClass l a) => SwitchTrans a -> ((l a -> SwitchTrans a) -> b -> c) -> X b -> X c
+acceptChange st f action =
+    -- seriously, Dave, you need to stop this
+    fmap (f (\l -> st{ currLayout = Layout l})) action
+
+instance LayoutClass SwitchTrans a where
+    description _ = "SwitchTrans"
+
+    doLayout st r s = currLayout st `unLayout` \l -> do
+        --io $ hPutStrLn stderr $ "[ST]{ " ++ show st
+        x{- @(_, w) -} <- acceptChange st (fmap . fmap) (doLayout l r s)
+        --io $ hPutStrLn stderr $ "[ST]} " ++ show w
+        return x
+
+    pureLayout st r s = currLayout st `unLayout` \l -> pureLayout l r s
+
+    handleMessage st m
+        | Just (Disable tag) <- fromMessage m
+        , M.member tag (filters st)
+            = provided (currTag st == Just tag) $ disable
+        | Just (Enable tag) <- fromMessage m
+        , Just alt <- M.lookup tag (filters st)
+            = provided (currTag st /= Just tag) $ enable tag alt
+        | Just (Toggle tag) <- fromMessage m
+        , Just alt <- M.lookup tag (filters st)
+            =
+            if (currTag st == Just tag) then
+                disable
+            else
+                enable tag alt
+        | Just ReleaseResources <- fromMessage m
+            = currLayout st `unLayout` \cl -> do
+                --io $ hPutStrLn stderr $ "[ST]~ " ++ show st
+                acceptChange st fmap (handleMessage cl m)
+        | Just Hide <- fromMessage m
+            = currLayout st `unLayout` \cl -> do
+                --io $ hPutStrLn stderr $ "[ST]< " ++ show st
+                x <- acceptChange st fmap (handleMessage cl m)
+                --io $ hPutStrLn stderr $ "[ST]> " ++ show x
+                return x
+        | otherwise = base st `unLayout` \b -> do
+            x <- handleMessage b m
+            case x of
+                Nothing -> return Nothing
+                Just b' -> currLayout st `unLayout` \cl -> do
+                    handleMessage cl (SomeMessage ReleaseResources)
+                    let b'' = Layout b'
+                    return . Just $ st{ base = b'', currLayout = currFilt st b'' }
+        where
+        enable tag alt = currLayout st `unLayout` \cl -> do
+            --io $ hPutStrLn stderr $ "[ST]+ " ++ show cl ++ " -> " ++ show (alt (base st))
+            handleMessage cl (SomeMessage ReleaseResources)
+            return . Just $ st{
+                currTag = Just tag,
+                currFilt = alt,
+                currLayout = alt (base st) }
+        disable = currLayout st `unLayout` \cl -> do
+            --io $ hPutStrLn stderr $ "[ST]- " ++ show cl ++ " -> " ++ show (base st)
+            handleMessage cl (SomeMessage ReleaseResources)
+            return . Just $ st{
+                currTag = Nothing,
+                currFilt = id,
+                currLayout = base st }
+
 -- | 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
+mkSwitch fs b = Layout st
     where
-    st = State{
+    st = SwitchTrans{
         base = b,
         currTag = Nothing,
         currLayout = b,
@@ -107,55 +192,3 @@ 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' }

Tabbed.hs

@@ -1,10 +1,12 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.Tabbed
--- Copyright   :  (c) David Roundy
+-- Copyright   :  (c) 2007 David Roundy, Andrea Rossato
 -- License     :  BSD-style (see xmonad/LICENSE)
 -- 
--- Maintainer  :  email@address.com
+-- Maintainer  :  droundy@darcs.net, andrea.rossato@unibz.it
 -- Stability   :  unstable
 -- Portability :  unportable
 --
@@ -15,110 +17,188 @@
 module XMonadContrib.Tabbed ( 
                              -- * Usage:
                              -- $usage
-                              tabbed
-                            , Shrinker, shrinkText
+                             tabbed
+                            , shrinkText
                             , TConf (..), defaultTConf
                             ) where
 
 import Control.Monad.State ( gets )
+import Control.Monad.Reader
+import Data.Maybe
+import Data.Bits
+import Data.List
 
 import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+
 import XMonad
-import XMonadContrib.Decoration
-import Operations ( focus, initColor )
+import Operations
 import qualified StackSet as W
 
 import XMonadContrib.NamedWindows
-import XMonadContrib.SimpleStacking ( simpleStacking )
-import XMonadContrib.LayoutHelpers ( idModify )
+import XMonadContrib.Invisible
+import XMonadContrib.XUtils
 
 -- $usage
 -- You can use this module with the following in your configuration file:
 --
 -- > import XMonadContrib.Tabbed
 --
--- > defaultLayouts :: [Layout Window]
--- > defaultLayouts = [ tabbed shrinkText defaultTConf
+-- > layouts :: [Layout Window]
+-- > layouts = [ Layout tiled
+-- >           , Layout $ Mirror tiled
+-- >           , Layout Full
+-- >
+-- >           -- Extension-provided layouts
+-- >           , Layout $ tabbed shrinkText defaultTConf
+-- >           ]
+-- >                  
 -- >                  , ... ]
 --
 -- You can also edit the default configuration options.
 --
--- > myconfig = defaultTConf { inactiveBolderColor = "#FF0000"
--- >                         , activeTextColor = "#00FF00"}
+-- > myTabConfig = defaultTConf { inactiveBorderColor = "#FF0000"
+-- >                            , activeTextColor = "#00FF00"}
 --
 -- and
 --
--- > defaultLayouts = [ tabbed shrinkText myconfig
--- >                  , ... ]
+-- > layouts = [ ...
+-- >           , Layout $ tabbed shrinkText myTabConfig ]
+
+-- %import XMonadContrib.Tabbed
+-- %layout , tabbed shrinkText defaultTConf
+
+tabbed :: Shrinker -> TConf -> Tabbed a
+tabbed s t = Tabbed (I Nothing) (I (Just s)) t
 
 data TConf = 
-    TConf { activeColor :: String
-          , inactiveColor :: String
-          , activeBorderColor :: String
-          , inactiveTextColor :: String
+    TConf { activeColor         :: String
+          , inactiveColor       :: String
+          , activeBorderColor   :: String
+          , inactiveTextColor   :: String
           , inactiveBorderColor :: String
-          , activeTextColor :: String
-          , fontName :: String
-          , tabSize :: Int
+          , activeTextColor     :: String
+          , fontName            :: String
+          , tabSize             :: Int
           } deriving (Show, Read)
 
 defaultTConf :: TConf
 defaultTConf = 
-    TConf { activeColor ="#999999"
-          , inactiveColor = "#666666"
-          , activeBorderColor = "#FFFFFF"
+    TConf { activeColor         = "#999999"
+          , inactiveColor       = "#666666"
+          , activeBorderColor   = "#FFFFFF"
           , inactiveBorderColor = "#BBBBBB"
-          , activeTextColor = "#FFFFFF"
-          , inactiveTextColor = "#BFBFBF"
-          , fontName = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-          , tabSize = 20
+          , activeTextColor     = "#FFFFFF"
+          , inactiveTextColor   = "#BFBFBF"
+          , fontName            = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
+          , tabSize             = 20
           }
 
-tabbed :: Shrinker -> TConf -> Layout Window
-tabbed s t = simpleStacking $ tabbed' s t
+data TabState = 
+    TabState { tabsWindows :: [(Window,Window)]
+             , scr         :: Rectangle
+             , fontS       :: FontStruct -- FontSet
+    }
 
-tabbed' :: Shrinker -> TConf -> Layout Window
-tabbed' shrinkT config =  Layout { doLayout = dolay shrinkT config, modifyLayout = idModify }
+data Tabbed a = 
+    Tabbed (Invisible Maybe TabState) (Invisible Maybe Shrinker) TConf
+    deriving (Show, Read)
 
-dolay :: Shrinker -> TConf
-      -> Rectangle -> W.Stack Window -> X ([(Window, Rectangle)], Maybe (Layout Window))
-dolay _ _ sc (W.Stack w [] []) = return ([(w,sc)], Nothing)
-dolay shr conf sc@(Rectangle x y wid _) s = withDisplay $ \dpy ->
-    do ac   <- io $ initColor dpy $ activeColor conf
-       ic <- io $ initColor dpy $ inactiveColor conf
-       abc <- io $ initColor dpy $ activeBorderColor conf
-       ibc <- io $ initColor dpy $ inactiveBorderColor conf
-       atc <- io $ initColor dpy $ activeTextColor conf 
-       itc <- io $ initColor dpy $ inactiveTextColor conf
-       let ws = W.integrate s
-           ts = gentabs conf x y wid (length ws)
-           tws = zip ts ws
-           focusColor w incol actcol = (maybe incol (\focusw -> if focusw == w 
-                                                                then actcol else incol) . W.peek) 
-                                       `fmap` gets windowset
-           make_tabs [] l = return l
-           make_tabs (tw':tws') l = do bc <- focusColor (snd tw') ibc abc
-                                       l' <- maketab tw' bc l
-                                       make_tabs tws' l'
-           maketab (t,ow) bg = newDecoration ow t 1 bg ac
-                                (fontName conf) (drawtab t ow) (focus ow)
-           drawtab r@(Rectangle _ _ wt ht) ow d w' gc fn =
-               do nw <- getName ow
-                  (fc,tc) <- focusColor ow (ic,itc) (ac,atc)
-                  io $ setForeground d gc fc
-                  io $ fillRectangles d w' gc [Rectangle 0 0 wt ht]
-                  io $ setForeground d gc tc
-                  centerText d w' gc fn r (show nw)
-           centerText d w' gc fontst (Rectangle _ _ wt ht) name =
-               do let (_,asc,_,_) = textExtents fontst name
-                      name' = shrinkWhile shr (\n -> textWidth fontst n >
-                                                     fromIntegral wt - fromIntegral (ht `div` 2)) name
-                      width = textWidth fontst name'
-                  io $ drawString d w' gc
-                         (fromIntegral (wt `div` 2) - fromIntegral (width `div` 2))
-                         ((fromIntegral ht + fromIntegral asc) `div` 2) name'
-       l' <- make_tabs tws $ tabbed shr conf
-       return (map (\w -> (w,shrink conf sc)) ws, Just l')
+instance LayoutClass Tabbed Window where
+    doLayout (Tabbed ist ishr conf) = doLay ist ishr conf
+    handleMessage                   = handleMess
+    description _                   = "Tabbed"
+
+doLay :: Invisible Maybe TabState -> Invisible Maybe Shrinker -> TConf 
+      -> Rectangle -> W.Stack Window -> X ([(Window, Rectangle)], Maybe (Tabbed Window))
+doLay ist ishr c sc (W.Stack w [] []) = do
+  whenIJust ist $ \st -> mapM_ deleteWindow (map fst $ tabsWindows st)
+  return ([(w,sc)], Just $ Tabbed (I Nothing) ishr c)
+doLay ist ishr conf sc@(Rectangle _ _ wid _) s@(W.Stack w _ _) = do
+  let ws = W.integrate s
+      width = wid `div` fromIntegral (length ws)
+      -- initialize state
+  st <- case ist of
+          (I Nothing  ) -> initState conf sc ws
+          (I (Just ts)) -> if map snd (tabsWindows ts) == ws && scr ts == sc
+                           then return ts
+                           else do mapM_ deleteWindow (map fst $ tabsWindows ts)
+                                   tws <- createTabs conf sc ws
+                                   return (ts {scr = sc, tabsWindows = zip tws ws})
+  mapM_ showWindow $ map fst $ tabsWindows st
+  mapM_ (updateTab ishr conf (fontS st) width) $ tabsWindows st
+  return ([(w,shrink conf sc)], Just (Tabbed (I (Just st)) ishr conf))
+
+handleMess :: Tabbed Window -> SomeMessage -> X (Maybe (Tabbed Window))
+handleMess (Tabbed (I (Just st@(TabState {tabsWindows = tws}))) ishr conf) m
+    | Just e <- fromMessage m :: Maybe Event = handleEvent ishr conf st e     >> return Nothing
+    | Just Hide             == fromMessage m = mapM_ hideWindow (map fst tws) >> return Nothing
+    | Just ReleaseResources == fromMessage m = do mapM_ deleteWindow $ map fst tws
+                                                  releaseFont (fontS st)
+                                                  return $ Just $ Tabbed (I Nothing) (I Nothing) conf
+handleMess _ _  = return Nothing
+
+handleEvent :: Invisible Maybe Shrinker -> TConf -> TabState -> Event -> X ()
+-- button press
+handleEvent ishr conf (TabState    {tabsWindows = tws,   scr          = screen, fontS         = fs }) 
+                      (ButtonEvent {ev_window   = thisw, ev_subwindow = thisbw, ev_event_type = t  })
+    | t == buttonPress, tl <- map fst tws, thisw `elem` tl || thisbw `elem` tl  = do
+  case lookup thisw tws of 
+    Just x  -> do focus x
+                  updateTab ishr conf fs width (thisw, x)
+    Nothing -> return ()
+    where width = rect_width screen `div` fromIntegral (length tws)
+-- propertyNotify
+handleEvent ishr conf (TabState      {tabsWindows = tws, scr = screen, fontS = fs }) 
+                      (PropertyEvent {ev_window   = thisw })
+    | thisw `elem` (map snd tws) = do
+  let tabwin = (fst $ fromJust $ find ((== thisw) . snd) tws, thisw)
+  updateTab ishr conf fs width tabwin
+    where width = rect_width screen `div` fromIntegral (length tws)
+-- expose
+handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) 
+                      (ExposeEvent {ev_window   = thisw })
+    | thisw `elem` (map fst tws) = do
+  updateTab ishr conf fs width (thisw, fromJust $ lookup thisw tws)
+    where width = rect_width screen `div` fromIntegral (length tws)
+handleEvent _ _ _ _ =  return ()
+
+initState :: TConf -> Rectangle -> [Window] -> X TabState
+initState conf sc ws = do
+  fs  <- initFont (fontName conf)
+  tws <- createTabs conf sc ws
+  return $ TabState (zip tws ws) sc fs
+
+createTabs :: TConf -> Rectangle -> [Window] -> X [Window]
+createTabs _ _ [] = return []
+createTabs c (Rectangle x y wh ht) owl@(ow:ows) = do
+  let wid    = wh `div` (fromIntegral $ length owl)
+      height = fromIntegral $ tabSize c
+      mask   = Just (exposureMask .|. buttonPressMask)
+  d  <- asks display
+  w  <- createNewWindow (Rectangle x y wid height) mask (inactiveColor c)
+  io $ restackWindows d $ w : [ow]
+  ws <- createTabs c (Rectangle (x + fromIntegral wid) y (wh - wid) ht) ows
+  return (w:ws)
+
+updateTab :: Invisible Maybe Shrinker -> TConf -> FontStruct -> Dimension -> (Window,Window) -> X ()
+updateTab ishr c fs wh (tabw,ow) = do
+  nw <- getName ow
+  let ht                   = fromIntegral $ tabSize c :: Dimension
+      focusColor win ic ac = (maybe ic (\focusw -> if focusw == win 
+                                                   then ac else ic) . W.peek) 
+                             `fmap` gets windowset
+  (bc',borderc',tc') <- focusColor ow
+                           (inactiveColor c, inactiveBorderColor c, inactiveTextColor c) 
+                           (activeColor   c, activeBorderColor   c, activeTextColor   c)
+  let s    = fromIMaybe shrinkText ishr 
+      name = shrinkWhile s (\n -> textWidth fs n >
+                            fromIntegral wh - fromIntegral (ht `div` 2)) (show nw)
+  paintAndWrite tabw fs wh ht 1 bc' borderc' tc' bc' AlignCenter name
+
+shrink :: TConf -> Rectangle -> Rectangle
+shrink c (Rectangle x y w h) = 
+    Rectangle x (y + fromIntegral (tabSize c)) w (h - fromIntegral (tabSize c))
 
 type Shrinker = String -> [String]
 
@@ -132,12 +212,3 @@ shrinkWhile sh p x = sw $ sh x
 shrinkText :: Shrinker
 shrinkText "" = [""]
 shrinkText cs = cs : shrinkText (init cs)
-
-shrink :: TConf -> Rectangle -> Rectangle
-shrink c (Rectangle x y w h) = Rectangle x (y + fromIntegral (tabSize c)) w (h - fromIntegral (tabSize c))
-
-gentabs :: TConf -> Position -> Position -> Dimension -> Int -> [Rectangle]
-gentabs _ _ _ _ 0 = []
-gentabs c x y w num = Rectangle x y (wid - 2) (fromIntegral (tabSize c) - 2)
-                      : gentabs c (x + fromIntegral wid) y (w - wid) (num - 1)
-                          where wid = w `div` (fromIntegral num)

TagWindows.hs

@@ -0,0 +1,205 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module       : XMonadContrib.TagWindows
+-- Copyright    : (c) Karsten Schoelzel <kuser@gmx.de>
+-- License      : BSD
+--
+-- Maintainer   : Karsten Schoelzel <kuser@gmx.de>
+-- Stability    : unstable
+-- Portability  : unportable
+--
+-- Functions for tagging windows and selecting them by tags.
+-----------------------------------------------------------------------------
+
+module XMonadContrib.TagWindows (
+                 -- * Usage
+                 -- $usage
+                 addTag, delTag, unTag,
+                 setTags, getTags, hasTag,
+                 withTaggedP,  withTaggedGlobalP, withFocusedP,
+                 withTagged ,  withTaggedGlobal ,
+                 focusUpTagged,   focusUpTaggedGlobal,
+                 focusDownTagged, focusDownTaggedGlobal,
+                 shiftHere, shiftToScreen,
+                 tagPrompt,
+                 tagDelPrompt
+                 ) where
+
+import Data.List (nub,concat,sortBy)
+
+import Control.Monad.State
+import StackSet hiding (filter)
+import Operations (windows, withFocused)
+
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+
+import XMonadContrib.XPrompt
+import XMonad
+
+-- $usage
+-- 
+-- To use window tags add in your Config.hs:
+--
+-- > import XMonadContrib.TagWindows
+-- > import XMonadContrib.XPrompt    -- to use tagPrompt
+-- 
+-- and add keybindings like as follows:
+--
+-- >   , ((modMask,                 xK_f  ), withFocused (addTag "abc")) 
+-- >   , ((modMask .|. controlMask, xK_f  ), withFocused (delTag "abc")) 
+-- >   , ((modMask .|. shiftMask,   xK_f  ), withTaggedGlobal "abc" sink) 
+-- >   , ((modMask,                 xK_d  ), withTaggedP "abc" (shiftWin "2")) 
+-- >   , ((modMask .|. shiftMask,   xK_d  ), withTaggedGlobalP "abc" shiftHere) 
+-- >   , ((modMask .|. controlMask, xK_d  ), focusUpTaggedGlobal "abc") 
+-- >   , ((modMask,                 xK_g  ), tagPrompt defaultXPConfig (\s -> withFocused (addTag s))) 
+-- >   , ((modMask .|. controlMask, xK_g  ), tagDelPrompt defaultXPConfig)
+-- >   , ((modMask .|. shiftMask,   xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedGlobal s float))
+-- >   , ((modWinMask,              xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedP s (shiftWin "2")))
+-- >   , ((modWinMask .|. shiftMask, xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedGlobalP s shiftHere))
+-- >   , ((modWinMask .|. controlMask, xK_g), tagPrompt defaultXPConfig (\s -> focusUpTaggedGlobal s)) 
+--
+-- NOTE: Tags are saved as space seperated string and split with 'unwords' thus
+--       if you add a tag "a b" the window will have the tags "a" and "b" but not "a b".
+
+-- %import XMonadContrib.TagWindows
+-- %import XMonadContrib.XPrompt        -- to use tagPrompt
+
+-- set multiple tags for a window at once (overriding any previous tags)
+setTags :: [String] -> Window -> X ()
+setTags = setTag . unwords
+
+-- set a tag for a window (overriding any previous tags)
+-- writes it to the "_XMONAD_TAGS" window property
+setTag :: String -> Window -> X ()
+setTag s w = withDisplay $ \d ->
+    io $ internAtom d "_XMONAD_TAGS" False >>= setTextProperty d w s
+
+-- read all tags of a window
+-- reads from the "_XMONAD_TAGS" window property
+getTags :: Window -> X [String]
+getTags w = withDisplay $ \d ->
+    io $ catch (internAtom d "_XMONAD_TAGS" False >>=
+                getTextProperty d w >>=
+                wcTextPropertyToTextList d)
+               (\_ -> return [[]])
+    >>= return . words . unwords
+
+-- check a window for the given tag
+hasTag :: String -> Window -> X Bool
+hasTag s w = (s `elem`) `liftM` getTags w
+
+-- add a tag to the existing ones
+addTag :: String -> Window -> X ()
+addTag s w = do
+    tags <- getTags w
+    if (s `notElem` tags) then setTags (s:tags) w else return ()
+
+-- remove a tag from a window, if it exists
+delTag :: String -> Window -> X ()
+delTag s w = do
+    tags <- getTags w
+    setTags (filter (/= s) tags) w
+
+-- remove all tags
+unTag :: Window -> X ()
+unTag = setTag ""
+
+-- Move the focus in a group of windows, which share the same given tag.
+-- The Global variants move through all workspaces, whereas the other
+-- ones operate only on the current workspace
+focusUpTagged, focusDownTagged, focusUpTaggedGlobal, focusDownTaggedGlobal :: String -> X ()
+focusUpTagged         = focusTagged' (reverse . wsToList)
+focusDownTagged       = focusTagged' wsToList
+focusUpTaggedGlobal   = focusTagged' (reverse . wsToListGlobal)
+focusDownTaggedGlobal = focusTagged' wsToListGlobal
+
+-- 
+wsToList :: (Ord i) => StackSet i l a s sd -> [a]
+wsToList ws = crs ++ cls
+    where
+        (crs, cls) = (cms down, cms (reverse . up))
+        cms f = maybe [] f (stack . workspace . current $ ws)
+
+wsToListGlobal :: (Ord i) => StackSet i l a s sd -> [a]
+wsToListGlobal ws = concat ([crs] ++ rws ++ lws ++ [cls])
+    where
+        curtag = tag . workspace . current $ ws
+        (crs, cls) = (cms down, cms (reverse . up))
+        cms f = maybe [] f (stack . workspace . current $ ws)
+        (lws, rws) = (mws (<), mws (>))
+        mws cmp = map (integrate' . stack) . sortByTag . filter (\w -> tag w `cmp` curtag) . workspaces $ ws
+        sortByTag = sortBy (\x y -> compare (tag x) (tag y))
+
+focusTagged' :: (WindowSet -> [Window]) -> String -> X ()
+focusTagged' wl t = gets windowset >>= findM (hasTag t) . wl >>=
+    maybe (return ()) (windows . focusWindow)
+
+findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)
+findM _ []      = return Nothing
+findM p (x:xs)  = do b <- p x
+                     if b then return (Just x) else findM p xs
+
+-- apply a pure function to windows with a tag
+withTaggedP, withTaggedGlobalP :: String -> (Window -> WindowSet -> WindowSet) -> X ()
+withTaggedP       t f = withTagged'       t (winMap f)
+withTaggedGlobalP t f = withTaggedGlobal' t (winMap f)
+
+winMap :: (Window -> WindowSet -> WindowSet) -> [Window] -> X ()
+winMap f tw = when (tw /= []) (windows $ foldl1 (.) (map f tw))
+
+withTagged, withTaggedGlobal :: String -> (Window -> X ()) -> X ()
+withTagged       t f = withTagged'       t (mapM_ f)
+withTaggedGlobal t f = withTaggedGlobal' t (mapM_ f)
+
+withTagged' :: String -> ([Window] -> X ()) -> X ()
+withTagged' t m = gets windowset >>=
+    filterM (hasTag t) . integrate' . stack . workspace . current >>= m
+
+withTaggedGlobal' :: String -> ([Window] -> X ()) -> X ()
+withTaggedGlobal' t m = gets windowset >>=
+    filterM (hasTag t) . concat . map (integrate' . stack) . workspaces >>= m
+
+withFocusedP :: (Window -> WindowSet -> WindowSet) -> X ()
+withFocusedP f = withFocused $ windows . f
+
+shiftHere :: (Ord a, Eq s, Eq i) => a -> StackSet i l a s sd -> StackSet i l a s sd
+shiftHere w s = shiftWin (tag . workspace . current $ s) w s
+
+shiftToScreen :: (Ord a, Eq s, Eq i) => s -> a -> StackSet i l a s sd -> StackSet i l a s sd
+shiftToScreen sid w s = case filter (\m -> sid /= screen m) ((current s):(visible s)) of
+                                []      -> s
+                                (t:_)   -> shiftWin (tag . workspace $ t) w s
+
+data TagPrompt = TagPrompt
+
+instance XPrompt TagPrompt where
+    showXPrompt TagPrompt = "Select Tag:   "
+
+
+tagPrompt :: XPConfig -> (String -> X ()) -> X ()
+tagPrompt c f = do
+  sc <- tagComplList
+  mkXPrompt TagPrompt c (mkComplFunFromList' sc) f
+
+tagComplList :: X [String]
+tagComplList = gets (concat . map (integrate' . stack) . workspaces . windowset) >>=
+    mapM getTags >>=
+    return . nub . concat
+
+
+tagDelPrompt :: XPConfig -> X ()
+tagDelPrompt c = do
+  sc <- tagDelComplList
+  if (sc /= []) 
+    then mkXPrompt TagPrompt c (mkComplFunFromList' sc) (\s -> withFocused (delTag s))
+    else return ()
+
+tagDelComplList :: X [String]
+tagDelComplList = gets windowset >>= maybe (return []) getTags . peek
+
+
+mkComplFunFromList' :: [String] -> String -> IO [String]
+mkComplFunFromList' l [] = return l
+mkComplFunFromList' l s =
+  return $ filter (\x -> take (length s) x == s) l

ThreeColumns.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.ThreeColumns
@@ -15,7 +17,7 @@
 module XMonadContrib.ThreeColumns (
                               -- * Usage
                               -- $usage
-                              threeCol
+                              ThreeCol(..)
                              ) where
 
 import XMonad
@@ -37,18 +39,24 @@ import Graphics.X11.Xlib
 --
 --  and add, to the list of layouts:
 --
--- > threeCol
+-- > ThreeCol nmaster delta ratio
 
-threeCol :: Int -> Rational -> Rational -> Layout a
-threeCol nmaster delta frac =
-    Layout { doLayout     = \r -> return . (\x->(x,Nothing)) .
-                                  ap zip (tile3 frac r nmaster . length) . W.integrate
-           , modifyLayout = \m -> return $ msum [fmap resize     (fromMessage m)
-                                                ,fmap incmastern (fromMessage m)] }
+-- %import XMonadContrib.ThreeColumns
+-- %layout , ThreeCol nmaster delta ratio
 
-    where resize Shrink = threeCol nmaster delta (max 0 $ frac-delta)
-          resize Expand = threeCol nmaster delta (min 1 $ frac+delta)
-          incmastern (IncMasterN d) = threeCol (max 0 (nmaster+d)) delta frac
+data ThreeCol a = ThreeCol Int Rational Rational deriving (Show,Read)
+
+instance LayoutClass ThreeCol a where
+    doLayout (ThreeCol nmaster _ frac) r =
+        return . (\x->(x,Nothing)) .
+        ap zip (tile3 frac r nmaster . length) . W.integrate
+    handleMessage (ThreeCol nmaster delta frac) m =
+        return $ msum [fmap resize     (fromMessage m)
+                      ,fmap incmastern (fromMessage m)]
+            where resize Shrink = ThreeCol nmaster delta (max 0 $ frac-delta)
+                  resize Expand = ThreeCol nmaster delta (min 1 $ frac+delta)
+                  incmastern (IncMasterN d) = ThreeCol (max 0 (nmaster+d)) delta frac
+    description _ = "ThreeCol"
 
 -- | tile3.  Compute window positions using 3 panes
 tile3 :: Rational -> Rectangle -> Int -> Int -> [Rectangle]

TwoPane.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.TwoPane
@@ -17,7 +19,7 @@
 module XMonadContrib.TwoPane (
                               -- * Usage
                               -- $usage
-                              twoPane
+                              TwoPane (..)
                              ) where
 
 import XMonad
@@ -32,19 +34,28 @@ import StackSet ( focus, up, down)
 --
 --  and add, to the list of layouts:
 --
--- > twoPane defaultDelta (1%2)
+-- > , (Layout $ TwoPane 0.03 0.5)
 
-twoPane :: Rational -> Rational -> Layout a
-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)]
-                        [] -> case down st of
-                                (next:_) -> [(focus st,left),(next,right)]
-                                [] -> [(focus st, rect)]
-        where (left, right) = splitHorizontallyBy split rect
+-- %import XMonadContrib.TwoPane
+-- %layout , (Layout $ TwoPane 0.03 0.5)
+
+data TwoPane a = 
+    TwoPane Rational Rational 
+    deriving ( Show, Read )
+
+instance LayoutClass TwoPane a where
+    doLayout (TwoPane _ split) r s = return (arrange r s,Nothing)
+        where
+          arrange rect st = case reverse (up st) of
+                              (master:_) -> [(master,left),(focus st,right)]
+                              [] -> case down st of
+                                      (next:_) -> [(focus st,left),(next,right)]
+                                      [] -> [(focus st, rect)]
+              where (left, right) = splitHorizontallyBy split rect
+
+    handleMessage (TwoPane delta split) x = 
+        return $ case fromMessage x of
+                   Just Shrink -> Just (TwoPane delta (split - delta))
+                   Just Expand -> Just (TwoPane delta (split + delta))
+                   _           -> Nothing
 
-    message x = return $ case fromMessage x of
-                    Just Shrink -> Just (twoPane delta (split - delta))
-                    Just Expand -> Just (twoPane delta (split + delta))
-                    _           -> Nothing

ViewPrev.hs

@@ -21,8 +21,6 @@ import XMonad
 import Operations 
 import qualified StackSet as W
 
-viewPrev' :: (Eq a, Eq s, Eq i) => W.StackSet i a s sd -> W.StackSet i a s sd
-viewPrev' x = W.view (W.tag . head . W.hidden $ x) x
-
 viewPrev :: X ()
 viewPrev = windows viewPrev'
+    where viewPrev' x = W.view (W.tag . head . W.hidden $ x) x

Warp.hs

@@ -21,7 +21,6 @@ module XMonadContrib.Warp (
                           ) where
 
 import Data.Ratio
-import Data.Maybe
 import Data.List
 import Control.Monad.RWS
 import Graphics.X11.Xlib
@@ -45,12 +44,16 @@ my Config.hs:
 Note that warping to a particular screen may change the focus.
 -}
 
+-- %import XMonadContrib.Warp
+-- %keybind , ((modMask,   xK_z     ), warpToWindow (1%2) (1%2)) -- @@ Move pointer to currently focused window
+-- %keybindlist ++
+-- %keybindlist -- mod-ctrl-{w,e,r} @@ Move mouse pointer to screen 1, 2, or 3
+-- %keybindlist [((modMask .|. controlMask, key), warpToScreen sc (1%2) (1%2))
+-- %keybindlist     | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..]]
+
 fraction :: (Integral a, Integral b) => Rational -> a -> b
 fraction f x = floor (f * fromIntegral x)
 
-ix :: Int -> [a] -> Maybe a
-ix n = listToMaybe . take 1 . drop n
-
 warp :: Window -> Position -> Position -> X ()
 warp w x y = withDisplay $ \d -> io $ warpPointer d none w 0 0 0 0 x y
 

WindowBringer.hs

@@ -0,0 +1,84 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.WindowBringer
+-- Copyright   :  Devin Mullins <me@twifkak.com>
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Devin Mullins <me@twifkak.com>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- dmenu operations to bring windows to you, and bring you to windows.
+-- That is to say, it pops up a dmenu with window names, in case you forgot
+-- where you left your XChat.
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.WindowBringer (
+                                    -- * Usage
+                                    -- $usage
+                                    gotoMenu, bringMenu, windowMapWith
+                                   ) where
+
+import Control.Monad.State (gets)
+import Data.Char (toLower)
+import qualified Data.Map as M
+import Graphics.X11.Xlib (Window())
+
+import Operations (windows)
+import qualified StackSet as W
+import XMonad (X)
+import qualified XMonad as X
+import XMonadContrib.Dmenu (dmenuMap)
+import XMonadContrib.NamedWindows (getName)
+
+-- $usage
+--
+-- Place in your Config.hs:
+--
+-- > import XMonadContrib.WindowBringer
+--
+-- and in the keys definition:
+--
+-- > , ((modMask .|. shiftMask, xK_g     ), gotoMenu)
+-- > , ((modMask .|. shiftMask, xK_b     ), bringMenu)
+
+-- %import XMonadContrib.WindowBringer
+-- %keybind , ((modMask .|. shiftMask, xK_g     ), gotoMenu)
+-- %keybind , ((modMask .|. shiftMask, xK_b     ), bringMenu)
+
+-- | Pops open a dmenu with window titles. Choose one, and you will be
+--   taken to the corresponding workspace.
+gotoMenu :: X ()
+gotoMenu = workspaceMap >>= actionMenu (windows . W.greedyView)
+ where workspaceMap = windowMapWith (W.tag . fst)
+
+-- | Pops open a dmenu with window titles. Choose one, and it will be
+--   dragged, kicking and screaming, into your current workspace.
+bringMenu :: X ()
+bringMenu = windowMap >>= actionMenu (windows . bringWindow)
+ where windowMap = windowMapWith snd
+       bringWindow w ws = W.shiftWin (W.tag . W.workspace . W.current $ ws) w ws
+
+-- | Calls dmenuMap to grab the appropriate element from the Map, and hands it
+--   off to action if found.
+actionMenu :: (a -> X ()) -> M.Map String a -> X ()
+actionMenu action windowMap = dmenuMap windowMap >>= flip X.whenJust action
+
+-- | Generates a Map from window name to <whatever you specify>. For use with
+--   dmenuMap.
+windowMapWith :: ((X.WindowSpace, Window) -> a) -> X (M.Map String a)
+windowMapWith value = do -- TODO: extract the pure, creamy center.
+  ws <- gets X.windowset
+  M.fromList `fmap` concat `fmap` mapM keyValuePairs (W.workspaces ws)
+ where keyValuePairs ws = mapM (keyValuePair ws) $ W.integrate' (W.stack ws)
+       keyValuePair ws w = flip (,) (value (ws, w)) `fmap` decorateName ws w
+
+-- | Returns the window name as will be listed in dmenu.
+--   Lowercased, for your convenience (since dmenu is case-sensitive).
+--   Tagged with the workspace ID, to guarantee uniqueness, and to let the user
+--   know where he's going.
+decorateName :: X.WindowSpace -> Window -> X String
+decorateName ws w = do
+  name <- fmap (map toLower . show) $ getName w
+  return $ name ++ " [" ++ W.tag ws ++ "]"

WindowNavigation.hs

@@ -0,0 +1,177 @@
+{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable
+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.WorkspaceDir
+-- Copyright   :  (c) 2007  David Roundy <droundy@darcs.net>
+-- License     :  BSD3-style (see LICENSE)
+-- 
+-- Maintainer  :  David Roundy <droundy@darcs.net>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- WindowNavigation is an extension to allow easy navigation of a workspace.
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.WindowNavigation ( 
+                                   -- * Usage
+                                   -- $usage
+                                   windowNavigation,
+                                   Navigate(..), Direction(..),
+                                   WNConfig (..), defaultWNConfig
+                                  ) where
+
+import Graphics.X11.Xlib ( Rectangle(..), Window, Pixel, setWindowBorder )
+import Control.Monad ( when )
+import Control.Monad.Reader ( ask )
+import Data.List ( nub, sortBy, (\\) )
+import XMonad
+import qualified StackSet as W
+import Operations ( windows, focus, LayoutMessages(..) )
+import XMonadContrib.LayoutModifier
+import XMonadContrib.Invisible
+import XMonadContrib.XUtils
+
+-- $usage
+-- You can use this module with the following in your Config.hs file:
+--
+-- > import XMonadContrib.WindowNavigation
+-- >
+-- > layoutHook = Layout $ windowNavigation defaultWNConfig $ Select ...
+--
+-- In keybindings:
+--
+-- >    , ((modMask, xK_Right), sendMessage $ Go R)
+-- >    , ((modMask, xK_Left), sendMessage $ Go L)
+-- >    , ((modMask, xK_Up), sendMessage $ Go U)
+-- >    , ((modMask, xK_Down), sendMessage $ Go D)
+
+-- %import XMonadContrib.WindowNavigation
+-- %keybind , ((modMask, xK_Right), sendMessage $ Go R)
+-- %keybind , ((modMask, xK_Left), sendMessage $ Go L)
+-- %keybind , ((modMask, xK_Up), sendMessage $ Go U)
+-- %keybind , ((modMask, xK_Down), sendMessage $ Go D)
+-- %keybind , ((modMask .|. controlMask, xK_Right), sendMessage $ Swap R)
+-- %keybind , ((modMask .|. controlMask, xK_Left), sendMessage $ Swap L)
+-- %keybind , ((modMask .|. controlMask, xK_Up), sendMessage $ Swap U)
+-- %keybind , ((modMask .|. controlMask, xK_Down), sendMessage $ Swap D)
+-- %layout -- include 'windowNavigation' in layoutHook definition above.
+-- %layout -- just before the list, like the following (don't uncomment next line):
+-- %layout -- layoutHook = Layout $ windowNavigation defaultWNConfig $ ...
+
+
+data Navigate = Go Direction | Swap Direction deriving ( Read, Show, Typeable )
+data Direction = U | D | R | L deriving ( Read, Show, Eq )
+instance Message Navigate
+
+data WNConfig = 
+    WNC { showNavigable :: Bool
+        , upColor       :: String
+        , downColor     :: String
+        , leftColor     :: String
+        , rightColor    :: String
+        } deriving (Show, Read)
+
+defaultWNConfig :: WNConfig
+defaultWNConfig = WNC True "#0000FF" "#00FFFF" "#FF0000" "#FF00FF"
+
+data NavigationState a = NS Point [(a,Rectangle)]
+
+data WindowNavigation a = WindowNavigation WNConfig (Invisible Maybe (NavigationState a)) deriving ( Read, Show )
+
+windowNavigation :: LayoutClass l a => WNConfig -> l a -> ModifiedLayout WindowNavigation l a
+windowNavigation conf = ModifiedLayout (WindowNavigation conf (I Nothing))
+
+instance LayoutModifier WindowNavigation Window where
+    redoLayout (WindowNavigation conf (I state)) rscr s wrs =
+        do XConf { normalBorder = nbc } <- ask
+           [uc,dc,lc,rc] <- mapM stringToPixel [upColor conf, downColor conf, leftColor conf, rightColor conf]
+           let dirc U = uc
+               dirc D = dc
+               dirc L = lc
+               dirc R = rc
+           let w    = W.focus s
+               r    = case filter ((==w).fst) wrs of ((_,x):_) -> x
+                                                     []        -> rscr
+               pt   = case state of Just (NS ptold _) | ptold `inrect` r -> ptold
+                                    _ -> center r
+               wrs' = filter ((/=w) . fst) wrs
+               wnavigable = nub $ concatMap
+                            (\d -> truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L]
+               wnavigablec = nub $ concatMap
+                            (\d -> map (\(win,_) -> (win,dirc d)) $
+                                   truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L]
+               wothers = case state of Just (NS _ wo) -> map fst wo
+                                       _              -> []
+           mapM_ (sc nbc) (wothers \\ map fst wnavigable)
+           when (showNavigable conf) $ mapM_ (\(win,c) -> sc c win) wnavigablec
+           return (wrs, Just $ WindowNavigation conf $ I $ Just $ NS pt wnavigable)
+
+    handleMess (WindowNavigation conf (I (Just (NS pt wrs)))) m
+        | Just (Go d) <- fromMessage m =
+                         case sortby d $ filter (inr d pt . snd) wrs of
+                         []        -> return Nothing
+                         ((w,r):_) -> do focus w
+                                         return $ Just $ WindowNavigation conf $ I $ Just $
+                                                NS (centerd d pt r) wrs
+        | Just (Swap d) <- fromMessage m =
+             case sortby d $ filter (inr d pt . snd) wrs of
+             []        -> return Nothing
+             ((w,_):_) -> do let swap st = unint (W.focus st) $ map (swapw (W.focus st)) $ W.integrate st
+                                 swapw y x | x == w = y
+                                           | x == y = w
+                                           | otherwise = x
+                                 unint f xs = case span (/= f) xs of
+                                              (u,_:dn) -> W.Stack { W.focus = f
+                                                                  , W.up = reverse u
+                                                                  , W.down = dn }
+                                              _ -> W.Stack { W.focus = f
+                                                           , W.down = xs
+                                                           , W.up = [] }
+                             windows $ W.modify' swap
+                             return Nothing
+        | Just Hide <- fromMessage m =
+                       do XConf { normalBorder = nbc } <- ask
+                          mapM_ (sc nbc . fst) wrs
+                          return $ Just $ WindowNavigation conf $ I $ Just $ NS pt []
+        | Just ReleaseResources <- fromMessage m =
+               handleMess (WindowNavigation conf (I $ Just (NS pt wrs))) (SomeMessage Hide)
+    handleMess _ _ = return Nothing
+
+truncHead :: [a] -> [a]
+truncHead (x:_) = [x]
+truncHead [] = []
+
+sc :: Pixel -> Window -> X ()
+sc c win = withDisplay $ \dpy -> io $ setWindowBorder dpy win c
+
+center :: Rectangle -> Point
+center (Rectangle x y w h) = P (fromIntegral x + fromIntegral w/2)  (fromIntegral y + fromIntegral h/2)
+
+centerd :: Direction -> Point -> Rectangle -> Point
+centerd d (P xx yy) (Rectangle x y w h) | d == U || d == D = P xx (fromIntegral y + fromIntegral h/2)
+                                        | otherwise = P (fromIntegral x + fromIntegral w/2) yy
+
+inr :: Direction -> Point -> Rectangle -> Bool
+inr D (P x y) (Rectangle l yr w h) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w &&
+                                     y <  fromIntegral yr + fromIntegral h
+inr U (P x y) (Rectangle l yr w _) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w &&
+                                     y >  fromIntegral yr
+inr R (P a x) (Rectangle b l _ w)  = x >= fromIntegral l && x < fromIntegral l + fromIntegral w &&
+                                     a <  fromIntegral b
+inr L (P a x) (Rectangle b l c w)  = x >= fromIntegral l && x < fromIntegral l + fromIntegral w &&
+                                     a >  fromIntegral b + fromIntegral c
+
+inrect :: Point -> Rectangle -> Bool
+inrect (P x y) (Rectangle a b w h) = x >  fromIntegral a && x < fromIntegral a + fromIntegral w &&
+                                     y >  fromIntegral b && y < fromIntegral b + fromIntegral h
+
+sortby :: Direction -> [(a,Rectangle)] -> [(a,Rectangle)]
+sortby U = sortBy (\(_,Rectangle _ y _ _) (_,Rectangle _ y' _ _) -> compare y' y)
+sortby D = sortBy (\(_,Rectangle _ y _ _) (_,Rectangle _ y' _ _) -> compare y y')
+sortby R = sortBy (\(_,Rectangle x _ _ _) (_,Rectangle x' _ _ _) -> compare x x')
+sortby L = sortBy (\(_,Rectangle x _ _ _) (_,Rectangle x' _ _ _) -> compare x' x)
+
+data Point = P Double Double

WindowPrompt.hs

@@ -0,0 +1,89 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.WindowPrompt
+-- Copyright   :  Devin Mullins <me@twifkak.com>
+--                Andrea Rossato <andrea.rossato@unibz.it>
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Devin  Mullins <me@twifkak.com>
+--                Andrea Rossato <andrea.rossato@unibz.it>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- xprompt operations to bring windows to you, and bring you to windows.
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.WindowPrompt
+    (
+    -- * Usage
+    -- $usage 
+    windowPromptGoto,
+    windowPromptBring
+    ) where
+
+import qualified Data.Map as M
+import Data.List
+
+import qualified StackSet as W
+import XMonad
+import Operations (windows)
+import XMonadContrib.XPrompt
+import XMonadContrib.WindowBringer
+
+-- $usage
+-- WindowPrompt brings windows to you and you to windows.
+-- That is to say, it pops up a prompt with window names, in case you forgot
+-- where you left your XChat.
+--
+-- Place in your Config.hs:
+--
+-- > import XMonadContrib.XPrompt
+-- > import XMonadContrib.WindowPrompt
+--
+-- and in the keys definition:
+--
+-- > , ((modMask .|. shiftMask, xK_g     ), windowPromptGoto  defaultXPConfig)
+-- > , ((modMask .|. shiftMask, xK_b     ), windowPromptBring defaultXPConfig)
+
+-- %import XMonadContrib.XPrompt
+-- %import XMonadContrib.WindowPrompt
+-- %keybind , ((modMask .|. shiftMask, xK_g     ), windowPromptGoto  defaultXPConfig)
+-- %keybind , ((modMask .|. shiftMask, xK_b     ), windowPromptBring defaultXPConfig)
+
+
+data WindowPrompt = Goto | Bring
+instance XPrompt WindowPrompt where 
+    showXPrompt Goto  = "Go to window:  "
+    showXPrompt Bring = "Bring me here:  "
+
+windowPromptGoto, windowPromptBring :: XPConfig -> X ()
+windowPromptGoto  c = doPrompt Goto  c
+windowPromptBring c = doPrompt Bring c
+
+-- | Pops open a prompt with window titles. Choose one, and you will be
+-- taken to the corresponding workspace.
+doPrompt :: WindowPrompt -> XPConfig -> X ()
+doPrompt t c = do
+  a <- case t of
+         Goto  -> return . gotoAction  =<< windowMapWith (W.tag . fst)                     
+         Bring -> return . bringAction =<< windowMapWith snd
+  wm <- windowMapWith id
+  mkXPrompt t c (compList wm) a
+
+    where
+
+      winAction a m    = flip whenJust (windows . a) . flip M.lookup m . unescape   
+      gotoAction       = winAction W.greedyView
+      bringAction      = winAction bringWindow
+      bringWindow w ws = W.shiftWin (W.tag . W.workspace . W.current $ ws) w ws
+
+      compList m s = return . filter (isPrefixOf s) . map (escape . fst) . M.toList $ m
+
+      escape []       = []
+      escape (' ':xs) = "\\ " ++ escape xs
+      escape (x  :xs) = x : escape xs
+
+      unescape []            = []
+      unescape ('\\':' ':xs) = ' ' : unescape xs
+      unescape (x:xs)        = x   : unescape xs

WmiiActions.hs

@@ -0,0 +1,101 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module       : XMonadContrib.WmiiActions
+-- Copyright    : (c) Juraj Hercek <juhe_xmonad@hck.sk>
+-- License      : BSD3
+--
+-- Maintainer   : Juraj Hercek <juhe_xmonad@hck.sk>
+-- Stability    : unstable
+-- Portability  : unportable
+--
+-- Provides `actions' as known from Wmii window manager (
+-- <http://wmii.suckless.org>). It also provides slightly better interface for
+-- running dmenu on xinerama screens. If you want to use xinerama functions,
+-- you have to apply following patch (see Dmenu.hs extension):
+-- <http://www.jcreigh.com/dmenu/dmenu-3.2-xinerama.patch>.  Don't forget to
+-- recompile dmenu afterwards ;-).
+-----------------------------------------------------------------------------
+
+module XMonadContrib.WmiiActions (
+                                 -- * Usage
+                                 -- $usage
+                                   wmiiActions
+                                 , wmiiActionsXinerama
+                                 , executables
+                                 , executablesXinerama
+                                 ) where
+
+import XMonad
+import XMonadContrib.Dmenu (dmenu, dmenuXinerama, runProcessWithInput)
+
+import Control.Monad (filterM, liftM, liftM2)
+import System.Directory (getDirectoryContents, doesFileExist, getPermissions, executable)
+
+-- $usage
+--
+-- You can use this module with the following in your Config.hs file:
+--
+-- > import XMonadContrib.WmiiActions
+--
+--  and add following to the list of keyboard bindings:
+--
+-- > ,((modMask, xK_a), wmiiActions "/home/joe/.wmii-3.5/")
+--
+-- or, if you are using xinerama, you can use
+--
+-- > ,((modMask, xK_a), wmiiActionsXinerama "/home/joe/.wmii-3.5/")
+--
+-- however, make sure you have also xinerama build of dmenu (for more
+-- information see "XMonadContrib.Dmenu" extension).
+
+-- | The 'wmiiActions' function takes the file path as a first argument and
+-- executes dmenu with all executables found in the provided path.
+wmiiActions :: FilePath -> X ()
+wmiiActions path =
+        wmiiActionsDmenu path dmenu
+
+-- | The 'wmiiActionsXinerama'  does the same as 'wmiiActions', but it shows
+-- dmenu only on workspace which currently owns focus.
+wmiiActionsXinerama :: FilePath -> X ()
+wmiiActionsXinerama path =
+        wmiiActionsDmenu path dmenuXinerama
+
+wmiiActionsDmenu :: FilePath -> ([String] -> X String) -> X ()
+wmiiActionsDmenu path dmenuBrand =
+        let path' = path ++ "/" in
+        getExecutableFileList path' >>= dmenuBrand >>= spawn . (path' ++)
+
+getExecutableFileList :: FilePath -> X [String]
+getExecutableFileList path =
+        io $ getDirectoryContents path >>=
+             filterM (\x -> let x' = path ++ x in
+                            liftM2 (&&)
+                              (doesFileExist x')
+                              (liftM executable (getPermissions x')))
+
+{-
+getExecutableFileList :: FilePath -> X [String]
+getExecutableFileList path =
+        io $ getDirectoryContents path >>=
+             filterM (doesFileExist . (path ++)) >>=
+             filterM (liftM executable . getPermissions . (path ++))
+-}
+
+-- | The 'executables' function runs dmenu_path script providing list of
+-- executable files accessible from $PATH variable.
+executables :: X ()
+executables = executablesDmenu dmenu
+
+-- | The 'executablesXinerama' function does the same as 'executables' function
+-- but on workspace which currently owns focus.
+executablesXinerama :: X ()
+executablesXinerama = executablesDmenu dmenuXinerama
+
+executablesDmenu :: ([String] -> X String) -> X ()
+executablesDmenu dmenuBrand =
+        getExecutablesList >>= dmenuBrand >>= spawn
+
+getExecutablesList :: X [String]
+getExecutablesList =
+        io $ liftM lines $ runProcessWithInput "dmenu_path" [] ""
+

WorkspaceDir.hs

@@ -1,4 +1,6 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.WorkspaceDir
@@ -9,12 +11,14 @@
 -- Stability   :  unstable
 -- Portability :  unportable
 --
--- WorkspaceDir is an exstension to set the current directory in a workspace.
+-- WorkspaceDir is an extension to set the current directory in a workspace.
 --
 -- Actually, it sets the current directory in a layout, since there's no way I
 -- know of to attach a behavior to a workspace.  This means that any terminals
 -- (or other programs) pulled up in that workspace (with that layout) will
 -- execute in that working directory.  Sort of handy, I think.
+-- 
+-- Requires the 'directory' package
 --
 -----------------------------------------------------------------------------
 
@@ -32,29 +36,39 @@ import Operations ( sendMessage )
 import XMonadContrib.Dmenu ( runProcessWithInput )
 import XMonadContrib.XPrompt ( XPConfig )
 import XMonadContrib.DirectoryPrompt ( directoryPrompt )
-import XMonadContrib.LayoutHelpers ( layoutModify )
-import XMonadContrib.XPrompt ( defaultXPConfig )
+import XMonadContrib.LayoutModifier
 
 -- $usage
 -- You can use this module with the following in your Config.hs file:
 --
 -- > import XMonadContrib.WorkspaceDir
 -- >
--- > defaultLayouts = map (workspaceDir "~") [ tiled, ... ]
+-- > layouts = map (workspaceDir "~") [ tiled, ... ]
 --
 -- In keybindings:
 --
 -- >  , ((modMask .|. shiftMask, xK_x     ), changeDir defaultXPConfig)
 
+-- %import XMonadContrib.WorkspaceDir
+-- %keybind , ((modMask .|. shiftMask, xK_x     ), changeDir defaultXPConfig)
+-- %layout -- prepend 'map (workspaceDir "~")' to layouts definition above,
+-- %layout -- just before the list, like the following (don't uncomment next line):
+-- %layout -- layouts = map (workspaceDir "~") [ tiled, ... ]
+
 
 data Chdir = Chdir String deriving ( Typeable )
 instance Message Chdir
 
-workspaceDir :: String -> Layout a -> Layout a
-workspaceDir wd = layoutModify dowd modwd
-    where dowd _ _ rws = scd wd >> return (rws, Nothing)
-          modwd m = return $ do Chdir wd' <- fromMessage m
-                                Just $ workspaceDir wd'
+data WorkspaceDir a = WorkspaceDir String deriving ( Read, Show )
+
+instance LayoutModifier WorkspaceDir a where
+    hook (WorkspaceDir s) = scd s
+    handleMess (WorkspaceDir _) m = return $ do Chdir wd <- fromMessage m
+                                                Just (WorkspaceDir wd)
+
+workspaceDir :: LayoutClass l a => String -> l a
+             -> ModifiedLayout WorkspaceDir l a
+workspaceDir s = ModifiedLayout (WorkspaceDir s)
 
 scd :: String -> X ()
 scd x = do x' <- io (runProcessWithInput "bash" [] ("echo -n " ++ x) `catch` \_ -> return x)

XMonadPrompt.hs

@@ -34,6 +34,10 @@ import XMonadContrib.Commands (defaultCommands, runCommand')
 -- >   , ((modMask .|. controlMask, xK_x), xmonadPrompt defaultXPConfig)
 --
 
+-- %import XMonadContrib.XPrompt
+-- %import XMonadContrib.XMonadPrompt
+-- %keybind , ((modMask .|. controlMask, xK_x), xmonadPrompt defaultXPConfig)
+
 data XMonad = XMonad
 
 instance XPrompt XMonad where

XPrompt.hs

@@ -1,4 +1,5 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE ExistentialQuantification #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonadContrib.XPrompt
@@ -34,17 +35,19 @@ module XMonadContrib.XPrompt (
                              , getLastWord
                              , skipLastWord
                              , splitInSubListsAt
+                             , breakAtSpace
                              , newIndex
                              , newCommand
-
                              ) where
 
 import Graphics.X11.Xlib
 import Graphics.X11.Xlib.Extras
 import XMonad  hiding (io)
-import Operations
+import Operations (initColor)
 import qualified StackSet as W
+import XMonadContrib.XUtils
 
+import Control.Arrow ((***),(&&&))
 import Control.Monad.Reader
 import Control.Monad.State
 import Data.Bits
@@ -56,7 +59,6 @@ import System.IO
 import System.Posix.Files
 
 -- $usage
---
 -- For usage examples see "XMonadContrib.ShellPrompt",
 -- "XMonadContrib.XMonadPrompt" or "XMonadContrib.SshPrompt"
 --
@@ -77,7 +79,7 @@ data XPState =
         , complWinDim        :: Maybe ComplWindowDim
         , completionFunction :: String -> IO [String]
         , gcon               :: GC
-        , fs                 :: FontStruct 
+        , fontS              :: FontStruct 
         , xptype             :: XPType
         , command            :: String 
         , offset             :: Int
@@ -86,16 +88,16 @@ data XPState =
         }
 
 data XPConfig =  
-    XPC { font           :: String     -- ^ Font
-        , bgColor        :: String     -- ^ Backgroud color
-        , fgColor        :: String     -- ^ Font color
-        , fgHLight       :: String     -- ^ Font color of a highlighted completion entry 
-        , bgHLight       :: String     -- ^ Backgroud color of a highlighted completion entry 
-        , borderColor    :: String     -- ^ Border color 
-        , borderWidth    :: Dimension  -- ^ Border width
-        , position       :: XPPosition -- ^ Position: 'Top' or 'Bottom'
-        , height         :: Dimension  -- ^ Window height
-        , historySize    :: Int        -- ^ The number of history entries to be saved
+    XPC { font              :: String     -- ^ Font
+        , bgColor           :: String     -- ^ Backgroud color
+        , fgColor           :: String     -- ^ Font color
+        , fgHLight          :: String     -- ^ Font color of a highlighted completion entry 
+        , bgHLight          :: String     -- ^ Backgroud color of a highlighted completion entry 
+        , borderColor       :: String     -- ^ Border color 
+        , promptBorderWidth :: Dimension  -- ^ Border width
+        , position          :: XPPosition -- ^ Position: 'Top' or 'Bottom'
+        , height            :: Dimension  -- ^ Window height
+        , historySize       :: Int        -- ^ The number of history entries to be saved
         } deriving (Show, Read)
 
 data XPType = forall p . XPrompt p => XPT p 
@@ -125,24 +127,24 @@ data XPPosition = Top
 
 defaultXPConfig :: XPConfig
 defaultXPConfig =
-    XPC { font        = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-        , bgColor     = "#333333"
-        , fgColor     = "#FFFFFF"
-        , fgHLight    = "#000000"
-        , bgHLight    = "#BBBBBB"
-        , borderColor = "#FFFFFF"
-        , borderWidth = 1
-        , position    = Bottom
-        , height      = 18
-        , historySize = 256
+    XPC { font              = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
+        , bgColor           = "#333333"
+        , fgColor           = "#FFFFFF"
+        , fgHLight          = "#000000"
+        , bgHLight          = "#BBBBBB"
+        , borderColor       = "#FFFFFF"
+        , promptBorderWidth = 1
+        , position          = Bottom
+        , height            = 18
+        , historySize       = 256
         }
 
 type ComplFunction = String -> IO [String]
 
 initState :: XPrompt p => Display -> Window -> Window -> Rectangle -> ComplFunction
           -> GC -> FontStruct -> p -> [History] -> XPConfig -> XPState
-initState d rw w s compl gc f pt h c =
-    XPS d rw w s Nothing Nothing compl gc f (XPT pt) "" 0 h c
+initState d rw w s compl gc fonts pt h c =
+    XPS d rw w s Nothing Nothing compl gc fonts (XPT pt) "" 0 h c
 
 -- | Creates a prompt given:
 --
@@ -165,15 +167,14 @@ mkXPrompt t conf compl action = do
   liftIO $ selectInput d w $ exposureMask .|. keyPressMask
   gc <- liftIO $ createGC d w
   liftIO $ setGraphicsExposures d gc False
-  fontS <- liftIO (loadQueryFont d (font conf) `catch`
-                   \_ -> loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*")
-  liftIO $ setFont d gc $ fontFromFontStruct fontS
   (hist,h) <- liftIO $ readHistory
-  let st = initState d rw w s compl gc fontS (XPT t) hist conf
+  fs <- initFont (font conf)
+  liftIO $ setFont d gc $ fontFromFontStruct fs
+  let st = initState d rw w s compl gc fs (XPT t) hist conf
   st' <- liftIO $ execStateT runXP st
 
+  releaseFont fs
   liftIO $ freeGC d gc
-  liftIO $ freeFont d fontS
   liftIO $ hClose h
   when (command st' /= "") $ do 
     let htw = take (historySize conf) (history st')
@@ -183,8 +184,7 @@ mkXPrompt t conf compl action = do
 runXP :: XP ()
 runXP = do
   st <- get
-  let d = dpy st
-      w = win st
+  let (d,w) = (dpy &&& win) st
   status <- io $ grabKeyboard d w True grabModeAsync grabModeAsync currentTime
   when (status == grabSuccess) $ do
           updateWindows
@@ -212,13 +212,12 @@ eventLoop action = do
 -- Main event handler
 handle :: KeyStroke -> Event -> XP ()
 handle k@(ks,_) e@(KeyEvent {ev_event_type = t})
-    | t == keyPress && ks == xK_Tab = do
+    | t == keyPress && ks == xK_Tab    = do
   c <- getCompletions
   completionHandle c k e
 handle ks (KeyEvent {ev_event_type = t, ev_state = m}) 
     | t == keyPress = keyPressHandle m ks
-handle _ (AnyEvent {ev_event_type = t, ev_window = w}) 
-    | t == expose = do 
+handle _ (ExposeEvent {ev_window = w}) = do
   st <- get
   when (win st == w) updateWindows
   eventLoop handle
@@ -264,26 +263,35 @@ data Direction = Prev | Next deriving (Eq,Show,Read)
 
 keyPressHandle :: KeyMask -> KeyStroke -> XP ()
 -- commands: ctrl + ... todo
-keyPressHandle mask _
-    | mask == controlMask = eventLoop handle -- TODO
-keyPressHandle _ (ks,_)
+keyPressHandle mask (ks,_)
+    | mask == controlMask =
+        case () of
+-- ctrl U
+          _ | ks == xK_u -> killBefore  >> go
+-- ctrl K
+            | ks == xK_k -> killAfter   >> go
+-- ctrl A
+            | ks == xK_a -> startOfLine >> go
+-- ctrl E
+            | ks == xK_e -> endOfLine   >> go
+-- Unhandled control sequence
+            | otherwise  -> eventLoop handle
 -- Return: exit
-    | ks == xK_Return = do historyPush
-                           return ()
+    | ks == xK_Return    = historyPush       >> return ()
 -- backspace
     | ks == xK_BackSpace = deleteString Prev >> go
 -- delete
-    | ks == xK_Delete = deleteString Next >> go
+    | ks == xK_Delete    = deleteString Next >> go
 -- left
-    | ks == xK_Left = moveCursor Prev >> go
+    | ks == xK_Left      = moveCursor   Prev >> go
 -- right
-    | ks == xK_Right = moveCursor Next >> go
+    | ks == xK_Right     = moveCursor   Next >> go
 -- up
-    | ks == xK_Up = moveHistory Prev >> go
+    | ks == xK_Up        = moveHistory  Prev >> go
 -- down
-    | ks == xK_Down = moveHistory Next >> go
+    | ks == xK_Down      = moveHistory  Next >> go
 -- escape: exit and discard everything
-    | ks  == xK_Escape = flushString >> return ()
+    | ks == xK_Escape = flushString >> return ()
     where go = updateWindows >> eventLoop handle
 -- insert a character
 keyPressHandle _ (_,s)
@@ -294,6 +302,27 @@ keyPressHandle _ (_,s)
 
 -- KeyPress and State
 
+-- | Kill the portion of the command before the cursor
+killBefore :: XP ()
+killBefore =
+  modify $ \s -> s { command = drop (offset s) (command s)
+                   , offset  = 0 }
+
+-- | Kill the portion of the command including and after the cursor
+killAfter :: XP ()
+killAfter =
+  modify $ \s -> s { command = take (offset s) (command s) }
+
+-- | Put the cursor at the end of line
+endOfLine :: XP ()
+endOfLine  =
+    modify $ \s -> s { offset = length (command s) }
+
+-- | Put the cursor at the start of line
+startOfLine :: XP ()
+startOfLine  =
+    modify $ \s -> s { offset = 0 }
+
 -- |  Flush the command string and reset the offest
 flushString :: XP ()
 flushString = do
@@ -301,7 +330,7 @@ flushString = do
  
 -- | Insert a character at the cursor position
 insertString :: String -> XP ()
-insertString str = 
+insertString str =
   modify (\s -> s { command = c (command s) (offset s), offset = o (offset s)} )
   where o oo = oo + length str
         c oc oo | oo >= length oc = oc ++ str
@@ -372,30 +401,25 @@ createWin d rw c s = do
 drawWin :: XP ()
 drawWin = do
   st <- get
-  let c = config st
-      d = dpy st
+  let (c,(d,(w,gc))) = (config &&& dpy &&& win &&& gcon) st
       scr = defaultScreenOfDisplay d
-      w = win st
       wh = widthOfScreen scr
       ht = height c
-      bw = borderWidth c
-      gc = gcon st
-      fontStruc = fs st
+      bw = promptBorderWidth c
   bgcolor <- io $ initColor d (bgColor c)
-  border <- io $ initColor d (borderColor c)
+  border  <- io $ initColor d (borderColor c)
   p <- io $ createPixmap d w wh ht
                          (defaultDepthOfScreen scr)
   io $ fillDrawable d p gc border bgcolor (fi bw) wh ht
-  printPrompt p gc fontStruc
+  printPrompt p
   io $ copyArea d p w gc 0 0 wh ht 0 0
   io $ freePixmap d p
 
-printPrompt :: Drawable -> GC -> FontStruct -> XP ()
-printPrompt drw gc fontst = do
-  c <- gets config
+printPrompt :: Drawable -> XP ()
+printPrompt drw = do
   st <- get
-  let d = dpy st
-      (prt,com,off) = (show (xptype st), command st, offset st)
+  let (gc,(c,(d,fs))) = (gcon &&& config &&& dpy &&& fontS) st
+      (prt,(com,off)) = (show . xptype &&& command &&& offset) st
       str = prt ++ com
       -- scompose the string in 3 part: till the cursor, the cursor and the rest
       (f,p,ss) = if off >= length com
@@ -403,8 +427,8 @@ printPrompt drw gc fontst = do
                  else let (a,b) = (splitAt off com) 
                       in (prt ++ a, [head b], tail b)
       ht = height c
-      (fsl,psl) = (textWidth fontst f, textWidth fontst p)
-      (_,asc,desc,_) = textExtents fontst str
+      (fsl,psl) = (textWidth fs *** textWidth fs) (f,p)
+      (_,asc,desc,_) = textExtents fs str
       y = fi $ ((ht - fi (asc + desc)) `div` 2) + fi asc
       x = (asc + desc) `div` 2
   fgcolor <- io $ initColor d $ fgColor c
@@ -416,7 +440,6 @@ printPrompt drw gc fontst = do
   -- reverse the colors and print the rest of the string
   io $ printString d drw gc fgcolor bgcolor (x + fsl + psl) y ss
 
-
 -- Completions
 
 getCompletions :: XP [String]
@@ -430,7 +453,7 @@ setComplWin w wi =
 
 destroyComplWin :: XP ()
 destroyComplWin = do
-  d <- gets dpy
+  d  <- gets dpy
   cw <- gets complWin
   case cw of
     Just w -> do io $ destroyWindow d w
@@ -455,17 +478,14 @@ createComplWin wi@(x,y,wh,ht,_,_) = do
 getComplWinDim :: [String] -> XP ComplWindowDim
 getComplWinDim compl = do
   st <- get
-  let c = config st
-      scr = screen st
+  let (c,(scr,fs)) = (config &&& screen &&& fontS) st
       wh = rect_width scr
       ht = height c
-      fontst = fs st
 
-  let compl_number = length compl
-      max_compl_len =  (fi ht `div` 2) + (maximum . map (textWidth fontst) $ compl)
+  let max_compl_len =  (fi ht `div` 2) + (maximum . map (textWidth fs) $ compl)
       columns = max 1 $ wh `div` (fi max_compl_len)
       rem_height =  rect_height scr - ht
-      (rows,r) = compl_number `divMod` fi columns
+      (rows,r) = (length compl) `divMod` fi columns
       needed_rows = max 1 (rows + if r == 0 then 0 else 1) 
       actual_max_number_of_rows = rem_height `div` ht
       actual_rows = min actual_max_number_of_rows (fi needed_rows)
@@ -474,7 +494,7 @@ getComplWinDim compl = do
                 Top -> (0,ht)
                 Bottom -> (0, (0 + rem_height - actual_height))
 
-  let (_,asc,desc,_) = textExtents fontst $ head compl
+  let (_,asc,desc,_) = textExtents fs $ head compl
       yp = fi $ (ht + fi (asc + desc)) `div` 2
       xp = (asc + desc) `div` 2
       yy = map fi . take (fi actual_rows) $ [yp,(yp + ht)..]
@@ -488,7 +508,7 @@ drawComplWin w compl = do
   let c = config st
       d = dpy st
       scr = defaultScreenOfDisplay d
-      bw = borderWidth c
+      bw = promptBorderWidth c
       gc = gcon st
   bgcolor <- io $ initColor d (bgColor c)
   fgcolor <- io $ initColor d (fgColor c)
@@ -544,7 +564,7 @@ printComplString d drw gc fc bc x y s = do
   if s == getLastWord (command st)
      then do bhc <- io $ initColor d (bgHLight $ config st)
              fhc <- io $ initColor d (fgHLight $ config st)
-             io $ printString d drw gc fhc bhc x y s
+             io $ printString d drw gc fhc bhc x y s 
      else io $ printString d drw gc fc bc x y s
 
 -- History
@@ -589,7 +609,7 @@ writeHistory hist = do
 
 -- | Prints a string on a 'Drawable'
 printString :: Display -> Drawable -> GC -> Pixel -> Pixel
-            -> Position -> Position -> String  -> IO ()
+            -> Position -> Position -> String -> IO ()
 printString d drw gc fc bc x y s = do
   setForeground d gc fc
   setBackground d gc bc
@@ -646,10 +666,17 @@ splitInSubListsAt i x = f : splitInSubListsAt i rest
 -- only one word
 getLastWord :: String -> String
 getLastWord str =
-    reverse . fst . break isSpace . reverse $ str
+    reverse . fst . breakAtSpace . reverse $ str
 
 -- | Skips the last word of the string, if the string is composed by
 -- more then one word. Otherwise returns the string.
 skipLastWord :: String -> String
 skipLastWord str =
-    reverse . snd . break isSpace . reverse $ str
+    reverse . snd . breakAtSpace . reverse $ str
+
+breakAtSpace :: String -> (String, String)
+breakAtSpace s 
+    | " \\" `isPrefixOf` s2 = (s1 ++ " " ++ s1', s2')
+    | otherwise = (s1, s2)
+      where (s1, s2 ) = break isSpace s
+            (s1',s2') = breakAtSpace $ tail s2

XPropManage.hs

@@ -0,0 +1,91 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module       : XMonadContrib.XPropManage
+-- Copyright    : (c) Karsten Schoelzel <kuser@gmx.de>
+-- License      : BSD
+--
+-- Maintainer   : Karsten Schoelzel <kuser@gmx.de>
+-- Stability    : unstable
+-- Portability  : unportable
+--
+-- A ManageHook matching on XProperties.
+-----------------------------------------------------------------------------
+
+module XMonadContrib.XPropManage (
+                 -- * Usage
+                 -- $usage
+                 xPropManageHook, XPropMatch, pmX, pmP
+                 ) where
+
+import Data.Char (chr)
+import Data.List (concat)
+
+import Control.Monad.State
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+
+import XMonad
+
+-- $usage
+-- 
+-- Add something like the following lines to Config.hs to use this module
+--
+-- > import XMonadContrib.XPropManage
+-- 
+-- > manageHook = xPropManageHook xPropMatches 
+-- >
+-- > xPropMatches :: [XPropMatch]
+-- > xPropMatches = [ ([ (wM_CLASS, any ("gimp"==)))], (\w -> float w >> return (W.shift "2")))
+-- >                , ([ (wM_COMMAND, any ("screen" ==)), (wM_CLASS, any ("xterm" ==))], pmX (addTag "screen"))
+-- >                , ([ (wM_NAME, any ("Iceweasel" `isInfixOf`))], pmP (W.shift "3"))
+-- >                ]
+--
+-- Properties known to work: wM_CLASS, wM_NAME, wM_COMMAND
+--
+-- A XPropMatch consists of a list of conditions and function telling what to do.
+--
+-- The list entries are pairs of an XProperty to match on (like wM_CLASS, wM_NAME)^1,
+-- and an function which matches onto the value of the property (represented as a List
+-- of Strings).
+--
+-- If a match succeeds the function is called immediately, can perform any action and then return
+-- a function to apply in 'windows' (see Operations.hs). So if the action does only work on the
+-- WindowSet use just 'pmP function'.
+--
+-- \*1 You can get the available properties of an application with the xprop utility. STRING properties
+-- should work fine. Others might not work.
+--
+
+type XPropMatch = ([(Atom, [String] -> Bool)], (Window -> X (WindowSet -> WindowSet)))
+
+pmX :: (Window -> X ()) -> Window -> X (WindowSet -> WindowSet)
+pmX f w = f w >> return id
+
+pmP :: (WindowSet -> WindowSet) -> Window -> X (WindowSet -> WindowSet)
+pmP f _ = return f
+
+xPropManageHook :: [XPropMatch] -> Window -> X (WindowSet -> WindowSet)
+xPropManageHook tms w = withDisplay $ \d -> do
+    fs <- mapM (matchProp d w `uncurry`) tms
+    return (foldr (.) id fs)
+
+matchProp :: Display -> Window -> [(Atom, [String] -> Bool)] -> (Window -> X (WindowSet -> WindowSet)) -> X (WindowSet -> WindowSet)
+matchProp d w tm tf = do
+    m <- and `liftM` sequence (map (\(k,f) -> f `liftM` getProp d w k) tm)
+    case m of
+        True   -> tf w
+        False  -> return id
+
+getProp :: Display -> Window -> Atom -> X ([String])
+getProp d w p = do
+    prop <- io $ catch (getTextProperty d w p >>= wcTextPropertyToTextList d) (\_ -> return [[]])
+    let filt q | q == wM_COMMAND = concat . map splitAtNull
+               | otherwise       = id
+    return (filt p prop)
+
+splitAtNull :: String -> [String]
+splitAtNull s = case dropWhile (== (chr 0)) s of
+    "" -> []
+    s' -> w : splitAtNull s''
+          where (w, s'') = break (== (chr 0)) s'
+

XSelection.hs

@@ -0,0 +1,162 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.XSelection
+-- Copyright   :  (C) 2007 Andrea Rossato, Matthew Sackman
+-- License     :  BSD3
+--
+-- Maintainer  :  Andrea Rossato <andrea.rossato@unibz.it>,
+--                Matthew Sackman <matthew@wellquite.org>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- A module for accessing and manipulating the X Window mouse selection (used in copy and pasting).
+-- getSelection and putSelection are adaptations of Hxsel.hs and Hxput.hs from XMonad-utils, available:
+--
+-- $ darcs get "http:\/\/gorgias.mine.nu\/repos\/xmonad-utils"
+-----------------------------------------------------------------------------
+
+module XMonadContrib.XSelection (
+                                 -- * Usage
+                                 -- $usage
+                                 getSelection, promptSelection, putSelection) where
+
+-- getSelection, putSelection's imports:
+import Graphics.X11.Xlib (allocaXEvent, createSimpleWindow, defaultScreen, destroyWindow, internAtom, nextEvent, openDisplay, rootWindow, selectionNotify, Display(), Atom(), XEventPtr(), selectionRequest, sendEvent, noEventMask, sync)
+import Graphics.X11.Xlib.Extras (currentTime, ev_event_type, getEvent, getWindowProperty8, xConvertSelection, xSetSelectionOwner, xGetSelectionOwner, changeProperty8, propModeReplace, setSelectionNotify, ev_requestor, ev_selection, ev_target, ev_property, ev_time, ev_event_display)
+import Data.Maybe (fromMaybe)
+import Control.Concurrent (forkIO)
+import Data.Char (chr, ord)
+import Control.Exception as E (catch)
+
+-- promptSelection's imports:
+import XMonad (io, spawn, X ())
+
+-- decode's imports
+import Foreign (Word8(), (.&.), shiftL, (.|.))
+
+{- $usage
+    Add 'import XMonadContrib.XSelection' to the top of Config.hs
+    Then make use of getSelection or promptSelection as needed; if
+    one wanted to run Firefox with the selection as an argument (say,
+    the selection is an URL you just highlighted), then one could add
+    to the Config.hs a line like thus:
+
+>  , ((modMask .|. shiftMask, xK_b     ), promptSelection "firefox")
+
+    TODO:
+
+             * Fix Unicode handling. Currently it's still better than calling
+               'chr' to translate to ASCII, though.
+               As near as I can tell, the mangling happens when the String is
+               outputted somewhere, such as via promptSelection's passing through
+               the shell, or GHCi printing to the terminal. utf-string has IO functions
+               which can fix this, though I do not know have to use them here. It's
+               a complex issue; see
+               <http://www.haskell.org/pipermail/xmonad/2007-September/001967.html>
+               and <http://www.haskell.org/pipermail/xmonad/2007-September/001966.html>.
+
+             * Possibly add some more elaborate functionality: Emacs' registers are nice.
+-}
+
+-- | Returns a String corresponding to the current mouse selection in X; if there is none, an empty string is returned.. Note that this is
+-- only reliable for ASCII text and currently mangles\/escapes more complex UTF-8 characters.
+getSelection :: IO String
+getSelection = do
+  dpy <- openDisplay ""
+  let dflt = defaultScreen dpy
+  rootw  <- rootWindow dpy dflt
+  win <- createSimpleWindow dpy rootw 0 0 200 100 0 0 0
+  p <- internAtom dpy "PRIMARY" True
+  ty <- E.catch
+               (E.catch
+                     (internAtom dpy "UTF8_STRING" False)
+                     (\_ -> internAtom dpy "COMPOUND_TEXT" False))
+             (\_ -> internAtom dpy "sTring" False)
+  clp <- internAtom dpy "BLITZ_SEL_STRING" False
+  xConvertSelection dpy p ty clp win currentTime
+  allocaXEvent $ \e -> do
+    nextEvent dpy e
+    ev <- getEvent e
+    if ev_event_type ev == selectionNotify
+       then do res <- getWindowProperty8 dpy clp win
+               return $ decode  . fromMaybe [] $ res
+       else destroyWindow dpy win >> return ""
+
+-- | Set the current X Selection to a given String.
+putSelection :: String -> IO ()
+putSelection text = do
+  dpy <- openDisplay ""
+  let dflt = defaultScreen dpy
+  rootw  <- rootWindow dpy dflt
+  win <- createSimpleWindow dpy rootw 0 0 200 100 0 0 0
+  p <- internAtom dpy "PRIMARY" True
+  ty <- internAtom dpy "UTF8_STRING" False
+  xSetSelectionOwner dpy p win currentTime
+  winOwn <- xGetSelectionOwner dpy p
+  if winOwn == win
+    then do forkIO ((allocaXEvent $ processEvent dpy ty text) >> destroyWindow dpy win) >> return ()
+    else do putStrLn "Unable to obtain ownership of the selection" >> destroyWindow dpy win
+  return ()
+                     where
+                       processEvent :: Display -> Atom -> [Char] -> XEventPtr -> IO ()
+                       processEvent dpy ty txt e = do
+                                                      nextEvent dpy e
+                                                      ev <- getEvent e
+                                                      if ev_event_type ev == selectionRequest
+                                                       then do print ev
+                                                    -- selection == eg PRIMARY
+                                                    -- target == type eg UTF8
+                                                    -- property == property name or None
+                                                               allocaXEvent $ \replyPtr -> do
+                                                                 changeProperty8 (ev_event_display ev)
+                                                                                 (ev_requestor ev)
+                                                                                 (ev_property ev)
+                                                                                 ty
+                                                                                 propModeReplace
+                                                                                 (map (fromIntegral . ord) txt)
+                                                                 setSelectionNotify replyPtr (ev_requestor ev) (ev_selection ev) (ev_target ev) (ev_property ev) (ev_time ev)
+                                                                 sendEvent dpy (ev_requestor ev) False noEventMask replyPtr
+                                                                 sync dpy False
+                                                       else do putStrLn "Unexpected Message Received"
+                                                               print ev
+                                                      processEvent dpy ty text e
+
+-- | A wrapper around getSelection. Makes it convenient to run a program with the current selection as an argument. This is convenient
+-- for handling URLs, in particular. For example, in your Config.hs you could bind a key to @promptSelection \"firefox\"@; this would allow you to
+-- highlight a URL string and then immediately open it up in Firefox.
+promptSelection :: String -> X ()
+promptSelection app = spawn . ((app ++ " ") ++) =<< io getSelection
+
+{- UTF-8 decoding for internal use in getSelection. This code is copied from Eric Mertens's utf-string library
+   <http://code.haskell.org/utf8-string/> (version 0.1), which is BSD-3 licensed, as is this module.
+   It'd be better to just import Codec.Binary.UTF8.String (decode), but then users of this would need to install it; Xmonad has enough
+   dependencies already. -}
+decode :: [Word8] -> String
+decode [    ] = ""
+decode (c:cs)
+  | c < 0x80  = chr (fromEnum c) : decode cs
+  | c < 0xc0  = replacement_character : decode cs
+  | c < 0xe0  = multi_byte 1 0x1f 0x80
+  | c < 0xf0  = multi_byte 2 0xf  0x800
+  | c < 0xf8  = multi_byte 3 0x7  0x10000
+  | c < 0xfc  = multi_byte 4 0x3  0x200000
+  | c < 0xfe  = multi_byte 5 0x1  0x4000000
+  | otherwise = replacement_character : decode cs
+  where
+    replacement_character :: Char
+    replacement_character = '\xfffd'
+
+    multi_byte :: Int -> Word8 -> Int -> [Char]
+    multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))
+      where
+        aux 0 rs acc
+          | overlong <= acc && acc <= 0x10ffff &&
+            (acc < 0xd800 || 0xdfff < acc)     &&
+            (acc < 0xfffe || 0xffff < acc)      = chr acc : decode rs
+          | otherwise = replacement_character : decode rs
+
+        aux n (r:rs) acc
+          | r .&. 0xc0 == 0x80 = aux (n-1) rs
+                               $ shiftL acc 6 .|. fromEnum (r .&. 0x3f)
+
+        aux _ rs     _ = replacement_character : decode rs

XUtils.hs

@@ -0,0 +1,180 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.XUtils
+-- Copyright   :  (c) 2007 Andrea Rossato
+-- License     :  BSD-style (see xmonad/LICENSE)
+-- 
+-- Maintainer  :  andrea.rossato@unibz.it
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- A module for painting on the screen
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.XUtils  ( 
+                             -- * Usage:
+                             -- $usage
+                             stringToPixel
+                             , initFont
+                             , releaseFont
+                             , createNewWindow
+                             , showWindow
+                             , hideWindow
+                             , deleteWindow
+                             , paintWindow
+                             , Align (..)
+                             , stringPosition
+                             , paintAndWrite
+                            ) where
+
+
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+
+import Control.Monad.Reader
+import Data.Maybe
+import XMonad
+import Operations
+
+-- $usage
+-- See Tabbed or DragPane for usage examples
+
+-- | Get the Pixel value for a named color: if an invalid name is
+-- given the black pixel will be returned.
+stringToPixel :: String -> X Pixel
+stringToPixel s = do
+  d <- asks display
+  io $ catch (getIt d) (fallBack d)
+    where getIt    d = initColor d s
+          fallBack d = const $ return $ blackPixel d (defaultScreen d)
+
+-- | Given a fontname returns the fonstructure. If the font name is
+--  not valid the default font will be loaded and returned.
+initFont :: String -> X FontStruct
+initFont s = do
+  d <- asks display
+  io $ catch (getIt d) (fallBack d)
+      where getIt    d = loadQueryFont d s
+            fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
+
+releaseFont :: FontStruct -> X ()
+releaseFont fs = do
+  d <- asks display
+  io $ freeFont d fs
+
+-- | Create a simple window given a rectangle. If Nothing is given
+-- only the exposureMask will be set, otherwise the Just value.
+-- Use 'showWindow' to map and hideWindow to unmap.
+createNewWindow :: Rectangle -> Maybe EventMask -> String -> X Window
+createNewWindow (Rectangle x y w h) m col = do
+  d   <- asks display
+  rw  <- asks theRoot
+  c <- stringToPixel col
+  win <- io $ createSimpleWindow d rw x y w h 0 c c
+  case m of
+    Just em -> io $ selectInput d win em
+    Nothing -> io $ selectInput d win exposureMask
+  return win
+
+-- | Map a window
+showWindow :: Window -> X ()
+showWindow w = do
+  d <- asks display
+  io $ mapWindow d w
+
+-- | unmap a window
+hideWindow :: Window -> X ()
+hideWindow w = do
+  d <- asks display
+  io $ unmapWindow d w
+
+-- | destroy a window
+deleteWindow :: Window -> X ()
+deleteWindow w = do
+  d <- asks display
+  io $ destroyWindow d w
+
+-- | Fill a window with a rectangle and a border
+paintWindow :: Window     -- ^ The window where to draw 
+            -> Dimension  -- ^ Window width
+            -> Dimension  -- ^ Window height 
+            -> Dimension  -- ^ Border width
+            -> String     -- ^ Window background color
+            -> String     -- ^ Border color
+            -> X ()
+paintWindow w wh ht bw c bc =
+    paintWindow' w (Rectangle 0 0 wh ht) bw c bc Nothing
+
+-- | String position
+data Align = AlignCenter | AlignRight | AlignLeft
+
+-- | Return the string x and y 'Position' in a 'Rectangle', given a
+-- 'FontStruct' and the 'Align'ment
+stringPosition :: FontStruct -> Rectangle -> Align -> String -> (Position,Position)
+stringPosition fs (Rectangle _ _ w h) al s = (x,y)
+    where width     = textWidth   fs s
+          (_,a,d,_) = textExtents fs s
+          y         = fi $ ((h - fi (a + d)) `div` 2) + fi a
+          x         = case al of 
+                        AlignCenter -> fi (w `div` 2) - fi (width `div` 2)
+                        AlignLeft   -> 1
+                        AlignRight  -> fi (w - (fi width + 1))
+
+-- | Fill a window with a rectangle and a border, and write a string at given position
+paintAndWrite :: Window     -- ^ The window where to draw 
+              -> FontStruct -- ^ The FontStruct
+              -> Dimension  -- ^ Window width
+              -> Dimension  -- ^ Window height 
+              -> Dimension  -- ^ Border width
+              -> String     -- ^ Window background color
+              -> String     -- ^ Border color
+              -> String     -- ^ String color
+              -> String     -- ^ String background color
+              -> Align      -- ^ String 'Align'ment
+              -> String     -- ^ String to be printed
+              -> X ()
+paintAndWrite w fs wh ht bw bc borc ffc fbc al str =
+    paintWindow' w r bw bc borc ms
+    where ms    = Just (fs,ffc,fbc,str)
+          r     = Rectangle x y wh ht
+          (x,y) = stringPosition fs (Rectangle 0 0 wh ht) al str
+
+-- This stuf is not exported
+
+paintWindow' :: Window -> Rectangle -> Dimension -> String -> String -> Maybe (FontStruct,String,String,String) -> X ()
+paintWindow' win (Rectangle x y wh ht) bw color b_color str = do
+  d  <- asks display
+  p  <- io $ createPixmap d win wh ht (defaultDepthOfScreen $ defaultScreenOfDisplay d)
+  gc <- io $ createGC d p
+  -- draw
+  io $ setGraphicsExposures d gc False
+  [c',bc'] <- mapM stringToPixel [color,b_color]
+  -- we start with the border
+  io $ setForeground d gc bc'
+  io $ fillRectangle d p gc 0 0 wh ht
+  -- and now again
+  io $ setForeground d gc c'
+  io $ fillRectangle d p gc (fi bw) (fi bw) ((wh - (bw * 2))) (ht - (bw * 2))
+  when (isJust str) $ do
+    let (fs,fc,bc,s) = fromJust str
+    io $ setFont d gc $ fontFromFontStruct fs
+    printString d p gc fc bc x y s
+  -- copy the pixmap over the window
+  io $ copyArea      d p win gc 0 0 wh ht 0 0
+  -- free the pixmap and GC
+  io $ freePixmap    d p
+  io $ freeGC        d gc
+
+-- | Prints a string on a 'Drawable'
+printString :: Display -> Drawable -> GC -> String -> String
+            -> Position -> Position -> String  -> X ()
+printString d drw gc fc bc x y s = do
+  [fc',bc'] <- mapM stringToPixel [fc,bc]
+  io $ setForeground   d gc fc'
+  io $ setBackground   d gc bc'
+  io $ drawImageString d drw gc x y s
+
+-- | Short-hand for 'fromIntegral'
+fi :: (Integral a, Num b) => a -> b
+fi = fromIntegral

scripts/generate-configs

@@ -0,0 +1,302 @@
+#!/bin/bash
+
+# generate-configs - Docstring parser for generating xmonad build configs with
+#                    default settings for extensions
+# Author: Alex Tarkovsky <alextarkovsky@gmail.com>
+# Released into the public domain
+
+# This script parses custom docstrings specifying build-time configuration data
+# from xmonad extension source files, then inserts the data into copies of
+# xmonad's Config.hs and xmonad.cabal files accordingly.
+#
+# Usage: generate-configs [ OPTIONS ] --main MAIN_DIR --contrib CONTRIB_DIR
+#
+# OPTIONS:
+#   --active,  -a              Insert data in active mode (default: passive)
+#   --contrib, -c CONTRIB_DIR  Path to contrib repository base directory
+#   --help,    -h              Show help
+#   --main,    -m MAIN_DIR     Path to main repository base directory
+#   --output,  -o OUTPUT_DIR   Output directory (default: CONTRIB_DIR)
+#
+# Data parsed from the extension source files is inserted into Config.hs in
+# either active or passive mode. The default is passive mode, in which the
+# inserted data is commented out. The --active option inserts the data
+# uncommented. Data inserted into xmonad.cabal is always inserted in active
+# mode regardless of specified options.
+#
+# The docstring markup can be extended as needed. Currently the following tags
+# are defined, shown with some examples:
+#
+# ~~~~~
+#
+# %cabalbuilddep
+#
+#     Cabal build dependency. Value is appended to the "build-depends" line in
+#     xmonad.cabal and automatically prefixed with ", ".  NB: Don't embed
+#     comments in this tag!
+#
+# -- %cabalbuilddep readline>=1.0
+#
+# %def
+#
+#     General definition. Value is appended to the end of Config.sh.
+#
+# -- %def commands :: [(String, X ())]
+# -- %def commands = defaultCommands
+#
+# %import
+#
+#     Module needed by Config.sh to build the extension. Value is appended to
+#     the end of the default import list in Config.sh and automatically
+#     prefixed with "import ".
+#
+# -- %import XMonadContrib.Accordion
+# -- %import qualified XMonadContrib.FlexibleManipulate as Flex
+#
+# %keybind
+#
+#     Tuple defining a key binding. Must be prefixed with ", ". Value is
+#     inserted at the end of the "keys" list in Config.sh.
+#
+# -- %keybind , ((modMask, xK_d), date)
+#
+# %keybindlist
+#
+#     Same as %keybind, but instead of a key binding tuple the definition is a
+#     list of key binding tuples (or a list comprehension producing them). This
+#     list is concatenated to the "keys" list must begin with the "++" operator
+#     rather than ", ".
+#
+# -- %keybindlist ++
+# -- %keybindlist -- mod-[1..9] @@ Switch to workspace N
+# -- %keybindlist -- mod-shift-[1..9] @@ Move client to workspace N
+# -- %keybindlist -- mod-control-shift-[1..9] @@ Copy client to workspace N
+# -- %keybindlist [((m .|. modMask, k), f i)
+# -- %keybindlist     | (i, k) <- zip [0..fromIntegral (workspaces-1)] [xK_1 ..]
+# -- %keybindlist     , (f, m) <- [(view, 0), (shift, shiftMask), (copy, shiftMask .|. controlMask)]]
+#
+# %layout
+#
+#     A layout. Must be prefixed with ", ". Value is inserted at the end of the
+#     "defaultLayouts" list in Config.sh.
+#
+# -- %layout , accordion
+#
+# %mousebind
+#
+#     Tuple defining a mouse binding. Must be prefixed with ", ". Value is
+#     inserted at the end of the "mouseBindings" list in Config.sh.
+#
+# -- %mousebind , ((modMask, button3), (\\w -> focus w >> Flex.mouseResizeWindow w))
+#
+# ~~~~~
+#
+# NB: '/' and '\' characters must be escaped with a '\' character!
+#
+# Tags may also contain comments, as illustrated in the %keybindlist examples
+# above. Comments are a good place for special user instructions:
+#
+# -- %def -- comment out default logHook definition above if you uncomment this:
+# -- %def logHook = dynamicLog
+
+# Markup tag to search for in source files.
+TAG_CABALBUILDDEP="%cabalbuilddep"
+TAG_DEF="%def"
+TAG_IMPORT="%import"
+TAG_KEYBIND="%keybind"
+TAG_KEYBINDLIST="%keybindlist"
+TAG_LAYOUT="%layout"
+TAG_MOUSEBIND="%mousebind"
+
+# Insert markers to search for in Config.sh and xmonad.cabal. Values are
+# extended sed regular expressions.
+INS_MARKER_CABALBUILDDEP='^build-depends:.*'
+INS_MARKER_IMPORT='-- % Extension-provided imports$'
+INS_MARKER_LAYOUT='-- % Extension-provided layouts$'
+INS_MARKER_KEYBIND='-- % Extension-provided key bindings$'
+INS_MARKER_KEYBINDLIST='-- % Extension-provided key bindings lists$'
+INS_MARKER_MOUSEBIND='-- % Extension-provided mouse bindings$'
+INS_MARKER_DEF='-- % Extension-provided definitions$'
+
+# Literal indentation strings. Values may contain escaped chars such as \t.
+INS_INDENT_CABALBUILDDEP=""
+INS_INDENT_DEF=""
+INS_INDENT_IMPORT=""
+INS_INDENT_KEYBIND="    "
+INS_INDENT_KEYBINDLIST="    "
+INS_INDENT_LAYOUT="                 "
+INS_INDENT_MOUSEBIND="    "
+
+# Prefix applied to inserted passive data after indent strings have been applied.
+INS_PREFIX_DEF="-- "
+INS_PREFIX_IMPORT="--import "
+INS_PREFIX_KEYBIND="-- "
+INS_PREFIX_KEYBINDLIST="-- "
+INS_PREFIX_LAYOUT="-- "
+INS_PREFIX_MOUSEBIND="-- "
+
+# Prefix applied to inserted active data after indent strings have been applied.
+ACTIVE_INS_PREFIX_CABALBUILDDEP=", "
+ACTIVE_INS_PREFIX_DEF=""
+ACTIVE_INS_PREFIX_IMPORT="import "
+ACTIVE_INS_PREFIX_KEYBIND=""
+ACTIVE_INS_PREFIX_KEYBINDLIST=""
+ACTIVE_INS_PREFIX_LAYOUT=""
+ACTIVE_INS_PREFIX_MOUSEBIND=""
+
+# Don't touch these
+opt_active=0
+opt_contrib=""
+opt_main=""
+opt_output=""
+
+generate_configs() {
+    for extension_srcfile in $(ls --color=never -1 "${opt_contrib}"/*.hs | head -n -1 | sort -r) ; do
+        for tag in $TAG_CABALBUILDDEP \
+                   $TAG_DEF \
+                   $TAG_IMPORT \
+                   $TAG_KEYBIND \
+                   $TAG_KEYBINDLIST \
+                   $TAG_LAYOUT \
+                   $TAG_MOUSEBIND ; do
+
+            ifs="$IFS"
+            IFS=$'\n'
+            tags=( $(sed -n -r -e "s/^.*--\s*${tag}\s//p" "${extension_srcfile}") )
+            IFS="${ifs}"
+
+            case $tag in
+                $TAG_CABALBUILDDEP) ins_indent=$INS_INDENT_CABALBUILDDEP
+                                    ins_marker=$INS_MARKER_CABALBUILDDEP
+                                    ins_prefix=$ACTIVE_INS_PREFIX_CABALBUILDDEP
+                                    ;;
+                $TAG_DEF)           ins_indent=$INS_INDENT_DEF
+                                    ins_marker=$INS_MARKER_DEF
+                                    ins_prefix=$INS_PREFIX_DEF
+                                    ;;
+                $TAG_IMPORT)        ins_indent=$INS_INDENT_IMPORT
+                                    ins_marker=$INS_MARKER_IMPORT
+                                    ins_prefix=$INS_PREFIX_IMPORT
+                                    ;;
+                $TAG_KEYBIND)       ins_indent=$INS_INDENT_KEYBIND
+                                    ins_marker=$INS_MARKER_KEYBIND
+                                    ins_prefix=$INS_PREFIX_KEYBIND
+                                    ;;
+                $TAG_KEYBINDLIST)   ins_indent=$INS_INDENT_KEYBINDLIST
+                                    ins_marker=$INS_MARKER_KEYBINDLIST
+                                    ins_prefix=$INS_PREFIX_KEYBINDLIST
+                                    ;;
+                $TAG_LAYOUT)        ins_indent=$INS_INDENT_LAYOUT
+                                    ins_marker=$INS_MARKER_LAYOUT
+                                    ins_prefix=$INS_PREFIX_LAYOUT
+                                    ;;
+                $TAG_MOUSEBIND)     ins_indent=$INS_INDENT_MOUSEBIND
+                                    ins_marker=$INS_MARKER_MOUSEBIND
+                                    ins_prefix=$INS_PREFIX_MOUSEBIND
+                                    ;;
+            esac
+
+            # Insert in reverse so values will ultimately appear in correct order.
+            for i in $( seq $(( ${#tags[*]} - 1 )) -1 0 ) ; do
+                [ -z "${tags[i]}" ] && continue
+                if [[ $tag == $TAG_CABALBUILDDEP ]] ; then
+                    sed -i -r -e "s/${ins_marker}/\\0${ins_prefix}${tags[i]}/" "${CABAL_FILE}"
+                else
+                    sed -i -r -e "/${ins_marker}/{G;s/$/${ins_indent}${ins_prefix}${tags[i]}/;}" "${CONFIG_FILE}"
+                fi
+            done
+
+            if [[ $tag != $TAG_CABALBUILDDEP && -n "${tags}" ]] ; then
+                ins_group_comment="${ins_indent}--   For extension $(basename $extension_srcfile .hs):"
+                sed -i -r -e "/${ins_marker}/{G;s/$/${ins_group_comment}/;}" "${CONFIG_FILE}"
+            fi
+        done
+    done
+}
+
+parse_opts() {
+    [[ -z "$1" ]] && show_usage 1
+
+    while [[ $# > 0 ]] ; do
+        case "$1" in
+            --active|-a)  opt_active=1
+                          shift ;;
+
+            --contrib|-c) shift
+                          if [[ -z "$1" || ! -d "$1" ]] ; then
+                              echo "Error: Option --contrib requires a directory as argument. See: generate-configs -h"
+                              exit 1
+                          fi
+                          opt_contrib="$1"
+                          shift ;;
+
+            --help|-h)    show_usage ;;
+
+            --main|-m)    shift
+                          if [[ -z "$1" || ! -d "$1" ]] ; then
+                              echo "Error: Option --main requires a directory as argument. See: generate-configs -h"
+                              exit 1
+                          fi
+                          opt_main="$1"
+                          shift ;;
+
+            --output|-o)  shift
+                          if [[ -z "$1" || ! -d "$1" ]] ; then
+                              echo "Error: Option --output requires a directory as argument. See: generate-configs -h"
+                              exit 1
+                          fi
+                          opt_output="$1"
+                          shift ;;
+
+            -*)           echo "Error: Unknown option ${1}. See: generate-configs -h"
+                          exit 1 ;;
+
+            *)            show_usage 1 ;;
+        esac
+    done
+
+    if [[ -z "$opt_main" ]] ; then
+      echo "Error: Missing required option --main. See: generate-configs -h"
+      exit 1
+    fi
+
+    if [[ -z "$opt_contrib" ]] ; then
+      echo "Error: Missing required option --contrib. See: generate-configs -h"
+      exit 1
+    fi
+}
+
+show_usage() {
+cat << EOF
+Usage: generate-configs [ OPTIONS ] --main MAIN_DIR --contrib CONTRIB_DIR
+
+OPTIONS:
+  --active,  -a              Insert data in active mode (default: passive)
+  --contrib, -c CONTRIB_DIR  Path to contrib repository base directory
+  --help,    -h              Show help
+  --main,    -m MAIN_DIR     Path to main repository base directory
+  --output,  -o OUTPUT_DIR   Output directory (default: CONTRIB_DIR)
+EOF
+    exit ${1:-0}
+}
+
+parse_opts $*
+
+[[ -z "$opt_output" ]] && opt_output="$opt_contrib"
+
+CABAL_FILE="${opt_output}/xmonad.cabal"
+CONFIG_FILE="${opt_output}/Config.hs"
+
+cp -f "${opt_main}/xmonad.cabal" "${CABAL_FILE}"
+cp -f "${opt_main}/Config.hs" "${CONFIG_FILE}"
+
+if [[ $opt_active == 1 ]] ; then
+    INS_PREFIX_DEF=$ACTIVE_INS_PREFIX_DEF
+    INS_PREFIX_IMPORT=$ACTIVE_INS_PREFIX_IMPORT
+    INS_PREFIX_KEYBIND=$ACTIVE_INS_PREFIX_KEYBIND
+    INS_PREFIX_KEYBINDLIST=$ACTIVE_INS_PREFIX_KEYBINDLIST
+    INS_PREFIX_LAYOUT=$ACTIVE_INS_PREFIX_LAYOUT
+    INS_PREFIX_MOUSEBIND=$ACTIVE_INS_PREFIX_MOUSEBIND
+fi
+
+generate_configs

scripts/xmonad-clock.c

@@ -30,7 +30,7 @@ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 /* configuration */
 #define REFRESH_RATE    60
 #define TIME_FORMAT     "%H.%M %a %b %d" 
-#define TIME_FORMAT2    "PDT %H.%M"
+#define TIME_FORMAT2    "SYD %H.%M"
  
 int main(void) {
     char b[34];
@@ -52,7 +52,7 @@ int main(void) {
         realtime  = localtime(&epochtime);
         strftime(b, sizeof(b), TIME_FORMAT, realtime);
 
-        setenv("TZ","America/Los_Angeles", 1);
+        setenv("TZ","Australia/Sydney", 1);
         pdttime      = time(NULL);
         pdtrealtime  = localtime(&pdttime);
         strftime(c, sizeof(c), TIME_FORMAT2, pdtrealtime);

tests/test_SwapWorkspaces.hs

@@ -0,0 +1,56 @@
+{-# OPTIONS -fglasgow-exts #-}
+
+import Data.List(find,union)
+import Data.Maybe(fromJust)
+import Test.QuickCheck
+
+import StackSet
+import Properties(T, NonNegative)
+import XMonadContrib.SwapWorkspaces
+
+-- Ensures that no "loss of information" can happen from a swap.
+prop_double_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =
+  t1 `tagMember` ss && t2 `tagMember` ss ==>
+  ss == swap (swap ss)
+  where swap = swapWorkspaces t1 t2
+
+-- Degrade nicely when given invalid data.
+prop_invalid_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =
+  not (t1 `tagMember` ss || t2 `tagMember` ss) ==>
+  ss == swapWorkspaces t1 t2 ss
+
+-- This doesn't pass yet. Probably should.
+-- prop_half_invalid_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =
+--   t1 `tagMember` ss && not (t2 `tagMember` ss) ==>
+--   ss == swapWorkspaces t1 t2 ss
+
+zipWorkspacesWith :: (Workspace i l a -> Workspace i l a -> n) -> StackSet i l a s sd ->
+                     StackSet i l a s sd -> [n]
+zipWorkspacesWith f s t = f (workspace $ current s) (workspace $ current t) :
+                          zipWith f (map workspace $ visible s) (map workspace $ visible t) ++
+                          zipWith f (hidden s)  (hidden t)
+
+-- Swap only modifies the workspaces tagged t1 and t2 -- leaves all others alone.
+prop_swap_only_two (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =
+  t1 `tagMember` ss && t2 `tagMember` ss ==>
+  and $ zipWorkspacesWith mostlyEqual ss (swapWorkspaces t1 t2 ss)
+  where mostlyEqual w1 w2 = map tag [w1, w2] `elem` [[t1, t2], [t2, t1]] || w1 == w2
+
+-- swapWithCurrent stays on current
+prop_swap_with_current (ss :: T) (t :: NonNegative Int) =
+  t `tagMember` ss ==>
+  layout before == layout after && stack before == stack after
+  where before = workspace $ current ss
+        after  = workspace $ current $ swapWithCurrent t ss
+
+main = do
+  putStrLn "Testing double swap"
+  quickCheck prop_double_swap
+  putStrLn "Testing invalid swap"
+  quickCheck prop_invalid_swap
+  -- putStrLn "Testing half-invalid swap"
+  -- quickCheck prop_half_invalid_swap
+  putStrLn "Testing swap only two"
+  quickCheck prop_swap_only_two
+  putStrLn "Testing swap with current"
+  quickCheck prop_swap_with_current