Xmonad/Config archive/Mntnoe's xmonad.hs

You download the whole configuration (icons inclusive) from my blog.

xmonad.hs

{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, MultiParamTypeClasses #-}

-------------------------------------------------------------------------- {{{
-- |
-- Module      :  xmonad
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
-- 
-- Modular xmonad config.
-- 
-- Highlights:
--   * pager with icons for DynamicLog
--   * per application configuration
--   * minimize windows
-- 
-- Requires xmonad 0.9. Note that this work is not finished.
-- There are still lot of things I want to behave differently,
-- and I need to do some cleanup here and there.
-- 
-- Still, I hope you can get inspired by some of my ideas. Enjoy :-)
-- 
-------------------------------------------------------------------------- }}}

-- IMPORTS {{{

-- Haskell modules
import Control.Monad (when, liftM)
import Data.IORef (IORef)
import Data.List
import Data.Maybe (isJust)
import qualified Data.Map as M
import System.IO (Handle)

-- XMonad modules
import XMonad hiding ( (|||) )
import XMonad.Actions.CycleSelectedLayouts
import XMonad.Actions.CycleWS
import XMonad.Actions.FloatKeys
import XMonad.Actions.FloatSnap
import XMonad.Actions.SwapWorkspaces (swapWithCurrent)
import XMonad.Hooks.DynamicLog
import XMonad.Hooks.EwmhDesktops
import XMonad.Hooks.ManageDocks
import XMonad.Hooks.ManageHelpers (doCenterFloat)
import XMonad.Hooks.Place
import XMonad.Hooks.RestoreMinimized
import XMonad.Hooks.ServerMode
import XMonad.Hooks.UrgencyHook
import XMonad.Layout.LayoutCombinators
import XMonad.Layout.Named
import XMonad.Layout.NoBorders
import XMonad.Layout.Reflect
import XMonad.Layout.ResizableTile
import qualified XMonad.StackSet as W
import XMonad.Util.Run (hPutStrLn)
import XMonad.Util.WorkspaceCompare (getSortByTag)

-- Custom modules
import App
import BorderColors
import Commands
import DMenu
import Panel
import Config
import IM
import Layout
import MyApps
import Pager
import Utils
import Workspace
-- }}}

-- MAIN {{{
main ::  IO ()
main = do 
    host <- getHost
    pipes  <- spawnPanels
    xmonad $ withUrgencyHook NoUrgencyHook $ ewmh $ myXConfig host pipes
-- }}}

-- SETTINGS {{{

-- | Layout to show initially, and when issuing the according keybinding.  My
--   desktop is widescreen, but not my laptop.
defaultLayout Laptop  = "Tall"
defaultLayout Netbook = "Wide"

cycledLayouts Laptop  = ["Mirror",            defaultLayout Laptop]
cycledLayouts Netbook = ["Accordion", "Tall", defaultLayout Netbook]

myWorkspaces = map show [1..8] ++ [hiddenWorkspaceTag, summonWorkspaceTag]

-- Colors
myNormalBorderColor  = defaultBG
myFocusedBorderColor = "#3939ff"
masterBorderColor    = "#ff1010"
floatBorderColor     = "#10c010"

myPlacement = withGaps (22, 0, 0, 0) $ smart (0.5,0.5)

myXConfig host pipes = XConfig
    { terminal            = "xterm" -- unused
    , focusFollowsMouse   = True
    , borderWidth         = 3
    , modMask             = mod5Mask -- unused
    , numlockMask         = mod2Mask
    , workspaces          = myWorkspaces
    , normalBorderColor   = myNormalBorderColor
    , focusedBorderColor  = myFocusedBorderColor
    , keys                = myKeys        host
    , mouseBindings       = myMouseBindings
    , handleEventHook     = myHandleEventHook
    , layoutHook          = myLayoutHook
    , manageHook          = myManageHook  host
    , logHook             = myLogHook     host pipes
    , startupHook         = myStartupHook host
    }
-- }}}

-- KEYS/MOUSE {{{

-- | The keybindings are optimized for the Colemak (<http://colemak.com>)
--   keyboard layout.  The keys are placed in the right side of the keyboard,
--   using right alt as the modifier.
myKeys host _ = M.fromList $

    makeKeys apps
    ++

    [ ((i , xK_comma), runCommand)
    , ((i , xK_slash), dmenuRun)
    , ((u , xK_h),     hideSummonWindows apps)

    -- See https://addons.mozilla.org/en-US/firefox/addon/61262.
    , ((is, xK_f),     spawn "firefox -unfocus")

    -- Enhance clipboard functionality in xterm (otherwise, xterm easily
    -- "forgets" the selection). Also, xclip will remember the selection
    -- even if the host app exits.
    , ((i , xK_z), spawn "xclip -selection primary -o | xclip -selection clipboard -i")


    -- FLOATING WINDOWS
    , ((u , xK_p), placeFocused $ myPlacement)
    , ((u , xK_b), withFocused $ windows . W.sink)


    -- WINDOW HANDLING
    , ((i , xK_j), windows W.focusDown >> warpToWindow')
    , ((i , xK_k), windows W.focusUp   >> warpToWindow')
    , ((is, xK_j), windows W.swapMaster)
    , ((i , xK_h), swapOrRaise)
    , ((is, xK_h), swapOrLower)

    , ((i , xK_s), windows $ hideFocused)
    , ((i , xK_r), windows $ restoreLast)

    , ((is, xK_n), kill)
    , ((mod1Mask,  xK_F4), kill)

    -- LAYOUT MESSAGES
    , ((i , xK_space), cycleThroughLayouts $ cycledLayouts host)
    , ((is, xK_space), sendMessage $ JumpToLayout $ defaultLayout host)

    , ((u , xK_n),     sendMessage $ JumpToLayout "NoBorders")
    , ((u , xK_u),     sendMessage $ ToggleStruts)

    , ((im, xK_Right), sendMessage Shrink)
    , ((im, xK_Left),  sendMessage Expand)
    , ((im, xK_Down),  sendMessage MirrorShrink)
    , ((im, xK_Up),    sendMessage MirrorExpand)

    , ((i , xK_Left),  withFocused $ keysMoveWindow (-300,    0))
    , ((i , xK_Right), withFocused $ keysMoveWindow ( 300,    0))
    , ((i , xK_Up),    withFocused $ keysMoveWindow (   0, -200))
    , ((i , xK_Down),  withFocused $ keysMoveWindow (   0,  200))
    , ((is, xK_Left),  withFocused $ snapMove L Nothing)
    , ((is, xK_Right), withFocused $ snapMove R Nothing)
    , ((is, xK_Up),    withFocused $ snapMove U Nothing)
    , ((is, xK_Down),  withFocused $ snapMove D Nothing)


    -- SESSION
    , ((i , xK_Delete),    spawn "gnome-session-save --shutdown-dialog")
    , ((is, xK_BackSpace), spawn "gnome-session-save --logout")
    , ((i , xK_BackSpace), killPanels >> restart "xmonad" True)

    -- WORKSPACES
    -- Note that I have swapped Y and J in my modified Colemak keyboard layout.
    , ((i , xK_y), doWithWS W.greedyView    Prev EmptyWS)
    , ((is, xK_y), doWithWS shiftView       Prev EmptyWS)
    , ((im, xK_y), doWithWS swapWithCurrent Prev EmptyWS)

    , ((i , xK_u), doWithWS W.greedyView    Prev NonEmptyWS)
    , ((is, xK_u), doWithWS shiftView       Prev NonEmptyWS)
    , ((im, xK_u), doWithWS swapWithCurrent Prev NonEmptyWS)

    , ((i , xK_i), doWithWS W.greedyView    Next NonEmptyWS)
    , ((is, xK_i), doWithWS shiftView       Next NonEmptyWS)
    , ((im, xK_I), doWithWS swapWithCurrent Next NonEmptyWS)

    , ((i , xK_o), doWithWS W.greedyView    Next EmptyWS)
    , ((is, xK_o), doWithWS shiftView       Next EmptyWS)
    , ((im, xK_o), doWithWS swapWithCurrent Next EmptyWS)

    , ((i , xK_l), doWithWS shiftView       Next EmptyWS)
    , ((is, xK_l), doWithWS W.shift         Next EmptyWS)

    , ((i , xK_7), swapNextScreen')
    , ((i , xK_8), toggleWS)
    , ((i , xK_9), screenWorkspace 0 >>= flip whenJust (windows . W.view)            >> warpToWindow')
    , ((is, xK_9), screenWorkspace 0 >>= flip whenJust (windows . shiftViewUngreedy) >> warpToWindow')
    , ((i , xK_0), screenWorkspace 1 >>= flip whenJust (windows . W.view)            >> warpToWindow')
    , ((is, xK_0), screenWorkspace 1 >>= flip whenJust (windows . shiftViewUngreedy) >> warpToWindow')
    ]

-- MOUSE
myMouseBindings _ = M.fromList $
    [ ((mod5Mask,               button1), focusAnd   mouseMoveWindow   $ snapMagicMove (Just 50) (Just 50))
    , ((mod5Mask .|. shiftMask, button1), focusAnd   mouseMoveWindow   $ snapMagicResize [L,R,U,D] (Just 50) (Just 50))
    , ((mod5Mask,               button3), focusAnd   mouseResizeWindow $ snapMagicResize [R,D] (Just 50) (Just 50))

    ]
  where

    -- | Focus and raise the window before performing a mouse operation.
    focusAnd job1 job2 w = focus w >> windows W.swapMaster >> job1 w >> job2 w
-- }}}

-- LAYOUTHOOK {{{

myLayoutHook  
    = avoidStruts
    $ smartBorders
    $ withIM (1/5) (Role "gimp-toolbox")
    (   (named "Wide"   $ Mirror       $ ResizableTall 1 (3/40) (2/3) [])
    ||| (named "Tall"   $ reflectHoriz $ ResizableTall 1 (3/40) (4/7) [])
    ||| (named "Mirror"                $ ResizableTall 1 (3/40) (4/7) [])
    ||| (twoAccordion)
    ||| (named "NoBorders" $ noBorders Full)
    )

-- }}}

-- MANAGEHOOK {{{

myManageHook xs = composeAll
    [ floats                 --> doCenterFloat
    , className =? "MPlayer" --> doFloat
    , ignores                --> doIgnore
    , appManageHook apps
    , manageDocks
    ]
  where
    floats = foldr1 (<||>)
        [ checkDialog
        , title     =? "." <&&> ( className =? "" <||> appName =? "." ) 
        , title     =? "VLC media player"
        , className =? "Nautilus" <&&> fmap (not . isSuffixOf " - File Browser") title
        , className =? "Firefox" <&&> fmap (/="Navigator") appName 
        , flip fmap className $ flip elem
            [ "Gnome_swallow"
            , "Gdmsetup"
            , "Xmessage"
            , "Zenity"
            ]
        ]

    ignores = foldr1 (<||>)
        [ className =? "Gnome-typing-monitor"
        ]
-- }}}

-- HANDLEEVENTHOOK {{{
myHandleEventHook = do
    restoreMinimizedEventHook
    serverModeEventHook' smCommands
-- }}}

-- STARTUP HOOK {{{
myStartupHook :: Host -> X ()
myStartupHook host = do
    broadcastMessage $ JumpToLayout $ defaultLayout $ host
    refresh
-- }}}

-- LOGHOOK {{{
myLogHook :: Host -> [Handle] -> X ()
myLogHook host pipes = do
    -- I found it least confusing when coloring the master window only.  This
    -- makes it easy to tell which window has focus, without moving your eyes
    -- to the border of the screen, as the coloring is based on the window
    -- position.
    colorWhen isMaster masterBorderColor
    -- Make it easy to distinguish between floating and non-floating windows.
    -- Sometimes I accidently makes a window floating without moving it out of
    -- its position.
    colorWhen isFloat floatBorderColor

    mapM_ (\pipe -> dynamicLogString (myPP host) >>= io . hPutStrLn pipe) pipes

-- TODO: refactor
myPP host = defaultPP 
    { ppCurrent         = highlight
    , ppVisible         = pad 2
    -- ppHidden overwrites colors of ppUrgent
    , ppHidden          = pad 6
    , ppHiddenNoWindows = pad 2
    , ppUrgent          = pad 6 . ((dzenColor "#01ce02" "#fcfb03") (adjust " ! ")++) -- temporary solution
    , ppTitle           = pad 2
    , ppLayout          = ifNonDefault host (highlight . adjust)
    , ppWsSep           = ""
    , ppSep             = " "
    , ppSort            = getSortByTag
    , ppOrder           = order
    , ppExtras          = [ labeledPager $ myPP host
                          ]
    } 
  where

    -- Ignore the original workspace list and use labeledPager instead.
    order (_:l:t:ws:[]) = (" " ++ ws):l:adjust t:[]
    order xs            = ["Error in order list: " ++ show xs]

    -- Hide the layout label when default layout is used.
    ifNonDefault host f s 
        | s == defaultLayout host = ""
        | otherwise               = f s

    highlight x = leftIcon ++ dzenColor hilightFG hilightBG x ++ rightIcon

    -- Called every time a text string is shown, making the font appear vertically 
    -- aligned with the icons.
    adjust x = "^p(;+2)" ++ x ++ "^p()"

    pad w x  = concat ["^p(", show w, ")", x, "^p(", show w, ")"]
-- }}}

-- vim: set ft=haskell fdm=marker fdl=1 fdc=4:

lib/App.hs

-------------------------------------------------------------------------- {{{
-- |
-- Module      :  App
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
-- 
-- Per application configuration. See MyApps for use.
-- 
-------------------------------------------------------------------------- }}}

module App
     ( App (..)
     , AppType (..)
     , nullApp
     , raiseApp
     , jumpToOrRestore
     , hideSummonWindows
     , summonWindow
     , hideFocused
     , restoreLast
     , appManageHook
     , makeKeys
     ) where

-- Haskell modules
import Control.Monad (filterM)
import Data.Maybe 
import Data.List

-- XMonad modules
import XMonad
import XMonad.Actions.WindowGo
import XMonad.Core
import XMonad.ManageHook (composeAll)
import qualified XMonad.StackSet as W

-- Custom modules
import Config
import Utils


-- | Holds WM related configuration for a given application.
data App = App
    { cmd     :: X ()                 -- ^ Command used to launch the application.
    , appType :: AppType              -- ^ See AppType.
    , query   :: Query Bool           -- ^ Used to identify the windows owned by the application.
    , key     :: (ButtonMask, KeySym) -- ^ Key binding to launch the application. (0,0) if no key
                                      --   binding is associated.
    , icon    :: String               -- ^ Relative path to the XPM icon used by the Pager module.
    , hook    :: Maybe ManageHook     -- ^ Application ManageHook.
    }


-- | Used when toggling between applications of type Summon.
--   As they are floating, it makes sense to only show one
--   at a time.
instance Eq App where
    (==) App { appType = Summon a _ } 
         App { appType = Summon b _ } = a == b
    _ == _ = False


data AppType = OpenNew -- ^ Open a new instance of the application each time.
             | JumpTo  -- ^ Jump to the workspace containing the application.
             | Summon  -- ^ Summon the application to the current workspace.
                       --   They are typically floating, and used for 
                       --   "transient" tasks.
                     String -- Identifier.
                     [App]  -- Applications to replace when toggling.


-- | Default to these settings when entries are omitted.
nullApp = App
    { cmd     = return ()
    , appType = OpenNew
    , query   = return False
    , key     = (0, 0)
    , icon    = defaultIcon
    , hook    = Nothing
    }


-- Focus an application. How this happens is specified by the application's AppType.
raiseApp App 
    { appType = OpenNew
    , cmd     = c
    }         = c
raiseApp App 
    { appType = JumpTo
    , query   = q
    , cmd     = c
    }         = jumpToOrRestore c q
raiseApp app@App 
    { appType = Summon _ apps
    , query   = q
    }         = summonWindow (filterSummonedApps apps) app


-- | Raise a window as follows. 
--   If there exists a matching window
--     * that is hidden, shift it to the current workspace.
--     * on the current workspace, hide it.
--     * on another workspace, jump to it.
--   Otherwise launch the application.
--   TODO: This behavior made it impossible to cycle between two windows,
--         as we now hide the current window instead of jumping to the next.
--         I'll have to rethink this one eventually, but as I seldomly need 
--         to cycle between windows of the same app, it is not a big
--         problem at the moment.
jumpToOrRestore c q = flip (ifWindows q) c $ \ws -> withWindowSet $ \s -> dispatch ws s
  where

    dispatch ws s = 
        case hidden of
             [] -> jumpToOrHide
             hws -> shiftToCurrent hws
      where

        hidden = filter (\w -> fromMaybe "" (W.findTag w s) == hiddenWorkspaceTag) ws

        shiftToCurrent hws = mapM_ (windows . W.shiftWin (W.currentTag s)) hws

        cws = maybe [] W.integrate $ W.stack $ W.workspace $ W.current s

        jumpToOrHide = 
            case cws `intersect` ws of
                 []  -> jumpTo $ W.peek s
                 iws -> mapM_ (windows . W.shiftWin hiddenWorkspaceTag) iws

        jumpTo (Just w) | w `elem` ws =
            let (_:y:_) = dropWhile (/=w) $ cycle ws -- cannot fail to match
            in  windows $ W.focusWindow y
        jumpTo _ = windows . W.focusWindow . head $ ws


-- | Hide all windows on the current workspace of the AppType Summon.
hideSummonWindows :: [App] ->  X ()
hideSummonWindows apps = withWindowSet $ \s -> do
    let ws = (maybe [] W.integrate . W.stack . W.workspace . W.current) s
        sWinsQuery = foldr1 (<||>) $ map query $ filterSummonedApps apps
    sWins <- filterM (runQuery sWinsQuery) ws
    mapM_ (windows . W.shiftWin summonWorkspaceTag) sWins


-- | Shift the specified app to the current workspace or hide it. 
summonWindow :: [App] -- ^ Apps of type Summon to replace.
             -> App   -- ^ App to summon.
             -> X ()
summonWindow apps app = withWindowSet $ \s -> do
    let ws = (maybe [] W.integrate . W.stack . W.workspace . W.current) s
        q = query app
        o = foldr1 (<||>) $ map query $ filter (app/=) apps

    matchingWins <- filterM (runQuery q) ws
    otherWins    <- filterM (runQuery o) ws

    case matchingWins of
        (x:_) -> do
            hideSummonWindows apps
        [] -> do
            mapM_ (windows . W.shiftWin summonWorkspaceTag) otherWins

            filterAll <- filterM (runQuery (query app)) (W.allWindows s)
            case filterAll of
                (x:_) -> windows $ W.shiftWin (W.currentTag s) x
                []    -> cmd app


-- | Hide the focused window. A hidden window is placed on a workspace that is
--   treated specially by all other workspace handling commands used.
hideFocused :: WindowSet -> WindowSet
hideFocused = W.shift hiddenWorkspaceTag


-- | Restore the window that was hidden most recently, like pushing and pulling
--   from a stack.
restoreLast :: WindowSet -> WindowSet
restoreLast s = maybe s (flip (W.shiftWin $ W.currentTag s) s) $ getHidden s
  where
    getHidden s 
        = listToMaybe
        $ maybe [] (W.integrate' . W.stack) 
        $ listToMaybe 
        $ filter (\wsp -> W.tag wsp == hiddenWorkspaceTag) 
        $ W.workspaces s


-- | Run all the hooks associated with the applications.
appManageHook :: [App] -> ManageHook
appManageHook = composeAll . fmap makeQueriedHook . filter hasHook
  where
    hasHook app = isJust $ hook app
    makeQueriedHook app@App 
        { query = q
        , hook  = Just h
        }       = q --> h
    makeQueriedHook _ = idHook -- never reached


-- | Generate the keybinding list from a list of Apps.
makeKeys :: [App] -> [((ButtonMask, KeySym), X ())]
makeKeys apps = map makeKey $ filter hasKey apps 
  where
    makeKey app = (key app, raiseApp app)
    hasKey app = key app /= (0, 0)


filterSummonedApps = filter (isSummonedApp . appType)
  where
    isSummonedApp (Summon _ _) = True
    isSummonedApp _            = False

lib/BorderColors.hs

{-# LANGUAGE FlexibleContexts #-}

-------------------------------------------------------------------------- {{{
-- |
-- Module      :  BorderColors 
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
-- 
-- Application specific border colors for XMonad.  You can color any kind of
-- windows, but I found it least confusing when coloring the master window
-- only.  This makes it easy to tell which window has focus, without moving
-- your eyes to the border of the screen, breaking your work flow.
-- 
-------------------------------------------------------------------------- }}}

module BorderColors (colorWhen) where

-- Haskell modules
import Control.Monad (when)

-- XMonad modules
import XMonad

-- | Set the border color when the query is satisfied.  Should be added to the
--   ManageHook.
colorWhen :: Query Bool -> String -> X ()
colorWhen q cl = withFocused $ \w -> runQuery q w >>= flip when (setWindowBorder' cl w)

-- | Give set the border color of a window to the given HTML color code.
setWindowBorder' ::(MonadReader XConf m, MonadIO m) => String -> Window -> m ()
setWindowBorder' c w = do
    XConf { display = d } <- ask
    ~(Just pc) <- io $ initColor d c
    io $ setWindowBorder d w pc

lib/Commands.hs

-------------------------------------------------------------------------- {{{
-- |
-- Module      :  Commands
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
-- 
-- Settings for XMonad.Actions.Commands. 
-- 
-------------------------------------------------------------------------- }}}

module Commands where 

-- Haskell modules
import qualified Data.Map as M
import Data.IORef (IORef)
import Data.List
import Data.Maybe
import System.Exit (exitWith, ExitCode(..) )

-- XMonad modules
import XMonad
import XMonad.Actions.Commands hiding (workspaceCommands)
import XMonad.Actions.WindowGo
import qualified XMonad.StackSet as W

-- Custom modules
import App
import Config
import DMenu

-- | Given a list of command\/action pairs, prompt the user to choose a
--   command and return the corresponding action.
-- runCommand :: [(String, X ())] -> X ()
runCommand = do
  let m = commandMap $ dmenuCommands
  choice <- dmenu (M.keys m)
  fromMaybe (return ()) (M.lookup choice m)

-- | Commands for DMenu.
dmenuCommands :: [(String, X ())]
dmenuCommands = 
        [ ("view-summon"        , windows $ W.view summonWorkspaceTag)
        , ("view-hidden"        , windows $ W.view hiddenWorkspaceTag)
        -- , ("restart"           , restart "xmonad" True)
        , ("restart-no-resume" , restart "xmonad" False)
        , ("refresh"           , refresh)
        , ("quit"              , io $ exitWith ExitSuccess)
        ]


-- | Commands for ServerMode.
--   TODO: integrate with dzen.
smCommands :: X [(String, X ())]
smCommands = do
    wsCmds <- workspaceCommands
    return $ take 10 (cycle wsCmds) ++ otherCommands
  where

    otherCommands = 
        [ ("focus-vim" , raiseNext q_vims)
        ]

    q_vims = className =? "Gvim" <||> (className =? "XTerm" <&&> fmap (isPrefixOf "vim:") title)

-- | Generate a list of commands to switch to.
workspaceCommands :: X [(String, X ())]
workspaceCommands = do
    ws <- asks $ workspaces . config
    return $ map makeEntry ws
  where
    makeEntry w = ("view-" ++ w, windows $ W.view w)

-- -- | Generate a list of commands dealing with multiple screens.
-- screenCommands :: [(String, X ())]
-- 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-")]
--                  ]

lib/Config.hs

-------------------------------------------------------------------------- {{{
-- |
-- Module      :  Config
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
-- 
-- Static module configuration which I am too lazy to pass around.
--
-------------------------------------------------------------------------- }}}

module Config where

-- XMonad modules
import XMonad


-- GUI

font         = "Consolas-9:rgba=rgb"
defaultBG    = "#dbdbdb"
defaultFG    = "#000000"
hilightBG    = "#5e8eba"
hilightFG    = "#ffffff"


-- PANEL

wTrayer = 100
wConky  = 140
wHbar   = 280 -- width of piped dzen
height  = "18"

hbar    =  "hbar -cmbdt | "
conkyrc = "/home/mntnoe/.conkyrc-dzen"

-- KEYS

i  = mod5Mask -- (I)SO_LEVEL5_SHIFT
u  = mod4Mask -- S(U)PER
s  = shiftMask
m  = mod1Mask
c  = controlMask
is = i .|. s
im = i .|. m
ic = i .|. c
us = u .|. s

-- APP

-- | Workspace containing "hidden" windows. Treated specially by workspace handling commands.
hiddenWorkspaceTag :: String
hiddenWorkspaceTag = "H"

-- | Workspace containing "summoned" windows. Treated specially by workspace handling commands.
summonWorkspaceTag :: String
summonWorkspaceTag = "S"


-- ICONS

-- | The icons located here are simply 16x16 XPM icons from hicolor, gnome and gnome-colors.
--   TODO: refactor

iconPath          = "/home/mntnoe/.xmonad/icons/default/"
hilightIconPath   = "/home/mntnoe/.xmonad/icons/hilight/"
grayIconPath      = "/home/mntnoe/.xmonad/icons/gray/"

defaultIcon       = "apps/application-default-icon.xpm"

defaultSepIcon    = "^i(/home/mntnoe/.xmonad/icons/default-sep.xpm)"
hilightSepIcon    = "^i(/home/mntnoe/.xmonad/icons/hilight-sep.xpm)"
leftIcon          = "^i(/home/mntnoe/.xmonad/icons/left.xpm)"
rightIcon         = "^i(/home/mntnoe/.xmonad/icons/right.xpm)"

lib/DMenu.hs

-------------------------------------------------------------------------- {{{
-- |
-- Module      :  DMenu 
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
-- 
-- DMenu helper functions.
-- 
-------------------------------------------------------------------------- }}}

module DMenu (dmenu, dmenuRun) where

-- Haskell modules
import Data.List (intercalate)

-- XMonad modules
import XMonad
import XMonad.Util.Run

-- Custom modules
import Config
import Utils

dmenu :: [String] -> X (String)
dmenu opts = run "dmenu" (dmenuArgs "Select:") opts


-- | Run command in path.
dmenuRun :: X ()
dmenuRun = do_ $ safeSpawn "dmenu_run" $ dmenuArgs "Run:"

dmenuArgs :: String -> [String]
dmenuArgs prompt =
    [ "-b"
    , "-fn" , font
    , "-nb" , defaultBG
    , "-nf" , defaultFG
    , "-sb" , hilightBG
    , "-sf" , hilightFG
    , "-p"  , prompt
    ]

run :: String -> [String] -> [String] -> X String
run cmd args opts = io $ runProcessWithInput cmd args (unlines opts)

lib/IM.hs

Skipped, as it is based on Xmonad.Layout.IM and only contains small modifications.

lib/Layout.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}

------------------------------------------------------------------------------
-- |
-- Module      :  Layout 
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
-- 
-- Custom layout algorithms. 
-- 
------------------------------------------------------------------------------

module Layout (
    twoAccordion
    ) where

-- XMonad modules
import XMonad
import qualified XMonad.StackSet as W
import XMonad.Layout.LimitWindows


-- Hacked Accordion layout.  Useful for LaTeX editing, where you switch between
-- an editor window and a preview window.  Accordion originally by
-- <glasser (@) mit.edu>.  
twoAccordion = limitSlice 2 TwoAccordion


data TwoAccordion a = TwoAccordion deriving ( Read, Show )

instance LayoutClass TwoAccordion 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/3) sc
       (center,  bottom) = splitVerticallyBy (1/2) allButTop
       (allButBottom, _) = splitVerticallyBy (2/3) 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 []
    description _ = "Accordion"

lib/MyApps.hs

-------------------------------------------------------------------------- {{{
-- |
-- Module      :  MyApps
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
-- 
-- Per application configuration. See App.
-- 
-------------------------------------------------------------------------- }}}

module MyApps (apps) where

-- Haskell modules
import Data.List

-- XMonad modules
import XMonad
import XMonad.Hooks.ManageHelpers (doRectFloat, doCenterFloat)
import XMonad.StackSet (RationalRect (RationalRect))

-- Custom modules
import App
import Config
import Utils


apps =

    -- Firefox 
    [ nullApp
      { cmd     = spawn "firefox"
      , appType = JumpTo
      , key     = (i, xK_f)
      , query   = className =? "Firefox"
      , icon    = "apps/firefox.xpm"
      }

    -- XTerm (new)
    , nullApp
      { cmd     = spawn "xterm"
      , appType = OpenNew
      , key     = (i, xK_x)
      }

    -- XTerm (jump)
    , nullApp
      { cmd     = spawn "xterm"
      , appType = JumpTo
      , key     = (i, xK_c)
      , query   = fmap (/="xterm-scratchpad") appName
                  <&&>
                  terminalWithTitle (\t -> not (isPrefixOf "root:" t)
                                        && not (isInfixOf  "emerge" t)
                                        && not (isPrefixOf "vim:" t))
      , icon    = "apps/utilities-terminal.xpm"
      }

    -- XTerm (superuser)
    , nullApp
      { query   = terminalWithTitle (\t -> isPrefixOf "root:" t 
                                        || isInfixOf "emerge" t)
      , icon    = "apps/gksu-root-terminal.xpm"
      }

    -- Vim
    , nullApp
      { cmd     = spawn "xvim"
      , appType = JumpTo
      , key     = (i, xK_v)
      , query   = ( className =? "XTerm" <&&> fmap (isPrefixOf "vim:" ) title) <||> className =? "Gvim"
      , icon    = "apps/vim.xpm"
      }

    -- Scratchpad
    , nullApp
      { cmd     = spawn $ xterm "xterm-scratchpad" "screen -dRRS scratchpad"
      , appType = Summon "scratchpad" apps
      , key     = (i, xK_Return)
      , query   = appName =? "xterm-scratchpad"
      , hook    = Just doCenterFloat
      , icon    = "apps/utilities-terminal.xpm"
      }

    -- Emacs
    , nullApp
      { cmd     = spawn "emacs"
      , appType = JumpTo
      , key     = (i, xK_e)
      , query   = className =? "Emacs" <||> fmap (isPrefixOf "emacs:") title
      , icon    = "apps/emacs.xpm"
      }

    -- Gmail
    , nullApp
      { cmd     = spawn "prism gmail"
      , appType = Summon "gmail" apps
      , key     = (u, xK_j)
      , query   = q_prism <&&> fmap ("Gmail" `isPrefixOf`) title
      , hook    = Just prismFloat
      , icon    = "apps/gmail.xpm"
      }

    -- Google Calendar
    , nullApp
      { cmd     = spawn "prism google.calendar"
      , appType = Summon "gcal" apps
      , key     = (u, xK_k)
      , query   = q_prism <&&> fmap (\ x -> isPrefixOf "madsnoe.dk Calendar" x 
                                         || isPrefixOf "Google Calendar" x) title
      , hook    = Just prismFloat
      , icon    = "apps/google-calendar.xpm"
      }

    -- Remember The Milk
    , nullApp
      { cmd     = spawn "prism remember.the.milk"
      , appType = Summon "rtm" apps
      , key     = (u, xK_l)
      , query   = q_prism <&&> fmap (isPrefixOf "Remember The Milk") title
      , hook    = Just prismFloat
      , icon    = "apps/rtm.xpm"
      }

    -- Ordbogen.com
    , nullApp
      { cmd     = spawn "prism ordbogen.com"
      , appType = Summon "ordbogen" apps
      , key     = (u, xK_semicolon)
      , query   = let prefix x = isPrefixOf "ordbogen" x || isPrefixOf "Ordbogen" x
                  in  q_prism <&&> fmap prefix title
      , hook    = Just $ doCenterFloat' (4/10) (5/6)
      , icon    = "apps/ordbogen.xpm"
      }

    -- Nautilus
    , nullApp
      { cmd     = spawn "nautilus ~"
      , appType = JumpTo
      , key     = (i, xK_d)
      , query   = className =? "Nautilus"
      , icon    = "apps/file-manager.xpm"
      }

    -- Eclipse
    , nullApp
      { cmd     = spawn "eclipse"
      , appType = JumpTo
      , key     = (u, xK_g)
      , query   = let eclipse = className =? "Eclipse" 
                      splash  = title =? "." <&&> ( className =? "" <||> appName =? "." ) 
                  in  eclipse <||> splash
      , icon    = "apps/eclipse.xpm"
      }

    -- XDvi
    , nullApp
      { query   = className =? "XDvi"
      , icon    = "apps/adobe.pdf.xpm"
      }

    -- Xpdf
    , nullApp
      { query   = className =? "Xpdf"
      , icon    = "apps/adobe.pdf.xpm"
      }

    -- Evince
    , nullApp
      { query   = className =? "Evince"
      , icon    = "apps/evince.xpm"
      }

    -- Acroread
    , nullApp
      { query   = className =? "Acroread"
      , icon    = "apps/adobe-reader.xpm"
      }

    -- MPlayer
    , nullApp
      { query   = className =? "MPlayer"
      , icon    = "apps/gnome-mplayer.xpm"
      }

    -- VLC
    , nullApp
      { query   = title =? "VLC media player"
      , icon    = "apps/vlc.xpm"
      }

    -- Gimp
    , nullApp
    { query     = className =? "Gimp"
    , icon      = "apps/gimp.xpm"
    }

    -- OpenOffice
    , nullApp
      { query   = className =? "OpenOffice.org 3.2" <&&> fmap (isSuffixOf "OpenOffice.org Writer") title
      , icon    = "apps/ooo-writer.xpm"
      }

    -- OpenOffice
    , nullApp
      { query   = className =? "OpenOffice.org 3.2" <&&> fmap (isSuffixOf "OpenOffice.org Calc") title
      , icon    = "apps/ooo-calc.xpm"
      }

    -- OpenOffice
    , nullApp
      { query   = className =? "OpenOffice.org 3.2" <&&> fmap (isSuffixOf "OpenOffice.org Base") title
      , icon    = "apps/ooo-base.xpm"
      }

    -- OpenOffice
    , nullApp
      { query   = className =? "OpenOffice.org 3.2" <&&> fmap (isSuffixOf "OpenOffice.org Draw") title
      , icon    = "apps/ooo-draw.xpm"
      }

    -- OpenOffice
    , nullApp
      { query   = className =? "OpenOffice.org 3.2" <&&> fmap (isSuffixOf "OpenOffice.org Impress") title
      , icon    = "apps/ooo-impress.xpm"
      }

    -- OpenOffice
    , nullApp
      { query   = className =? "OpenOffice.org 3.2"
      , icon    = "apps/ooo-gulls.xpm"
      }

    -- VirtualBox
    , nullApp
      { query   = className =? "VirtualBox"
      , icon    = "apps/vmware.xpm"
      }

    -- XChat
    , nullApp
      { query   = className =? "Xchat"
      , icon    = "apps/xchat-gnome.xpm"
      }

    
    -- Gnucash
    , nullApp
      { appType = JumpTo
      , query   = className =? "Gnucash"
      , icon    = "apps/gnucash-icon.xpm"
      }

    
    -- Audacity
    , nullApp
      { cmd     = spawn "audacity"
      , appType = JumpTo
      , query   = className =? "Audacity"
      , icon    = "apps/audacity.xpm"
      }

    
    -- Gnome-session
    , nullApp

      { query   = className =? "Gnome-session"
      , icon    = "apps/gnome-shutdown.xpm"
      }

    
    -- Rhythmbox
    , nullApp
      { query   = className =? "Rhythmbox"
      , icon    = "apps/rhythmbox.xpm"
      }


-- MARK --

    ]


-- Auxiliary functions

terminalWithTitle p = className =? "XTerm" <&&> fmap p title

q_typing_mon  = className =? "Gnome-typing-monitor"
q_nautilus_f  = className =? "Nautilus" <&&> fmap (not . isSuffixOf " - File Browser") title
q_eclipse_spl = title     =? "." <&&> ( className =? "" <||> appName =? "." )
q_prism       = className =? "Prism"
q_xterms      = className =? "XTerm"

prismFloat         = doCenterFloat' (8/10) (5/6)
doCenterFloat' w h = doRectFloat $ RationalRect ((1 - w)/2) ((1 - h)/2) w h

lib/Pager.hs

------------------------------------------------------------------------------
-- |
-- Module      :  Pager 
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
-- 
-- A pager for DynamicLog showing an for each window on each workspace.
-- TODO: Gets slow when there are many windows. Optimize! Not a problem
--       for casual use however.
-- 
------------------------------------------------------------------------------

module Pager (
    labeledPager
  ) where

-- XMonad modules
import XMonad
import Data.Char (toLower)
import Data.Maybe ( isJust, fromMaybe )
import qualified Data.Map as M
import Data.Map ( (!) )
import Data.List
import qualified XMonad.StackSet as W
import XMonad.Hooks.DynamicLog
import XMonad.Hooks.UrgencyHook

-- Custom modules
import App
import Config
import MyApps
import Utils

-- | The 'DynamicLog' logger to add to 'ppExtras' using the given pretty
--   printer and window label map.
labeledPager :: PP -> X (Maybe String)
labeledPager pp = do
    s       <- gets windowset
    urgents <- readUrgents
    sort'   <- ppSort pp
    wl      <- queryWindows s windowLabelMap
    return $ Just $ pprWindowSet' sort' urgents wl pp s

-- | like 'pprWindowSet', but append to each workspace the outcome of
--   'printWindows'.
pprWindowSet' :: ([W.Workspace String l Window] -> [W.Workspace String l Window])
                                                   -- ^ sorting function
              -> [Window]                          -- ^ urgent windows
              -> M.Map Window String               -- ^ window to symbol map
              -> PP                                -- ^ pretty-Printer
              -> W.StackSet String l Window sid sd -- ^ stack set
              -> String
pprWindowSet' sort' urgents wl pp s 
    = sepBy (ppWsSep pp) . map fmt . sort' $
            map W.workspace (W.current s : W.visible s) ++ W.hidden s
  where 
    this     = W.tag (W.workspace (W.current s))
    visibles = map (W.tag . W.workspace) (W.visible s)

    fmt ws   = (printer ws) pp $ print path ws
      where
        path
            | W.tag ws == this               = hilightIconPath
            | W.tag ws == summonWorkspaceTag = grayIconPath
            | W.tag ws == hiddenWorkspaceTag = grayIconPath
            | otherwise                      = iconPath

    printer ws
        | W.tag ws == this               = ppCurrent
        | W.tag ws `elem` visibles = ppVisible
        | any (\x -> maybe False (== W.tag ws) (W.findTag x s)) urgents  
                                    = \ppC -> ppUrgent ppC . ppHidden ppC
        | isJust (W.stack ws)      = ppHidden
        | otherwise                = ppHiddenNoWindows

    print path ws = printWindows path wl (W.integrate' $ W.stack ws)

-- | Output a list of strings, ignoring empty ones and separating the
--   rest with the given separator.
sepBy :: String   -- ^ separator
      -> [String] -- ^ fields to output
      -> String
sepBy sep = concat . intersperse sep . filter (not . null)

-- | Print a concatenated string of symbols for a list of windows.
printWindows :: String              -- ^ icon path
             -> M.Map Window String -- ^ window to symbol map
             -> [Window]            -- ^ windows on the workspace
             -> String
printWindows path wl ws = handleEmpty $ intercalate (icon path "sep.xpm") $ map (\w -> icon path $ fromMaybe defaultIcon (M.lookup w wl)) ws
  where

    icon path i = "^i(" ++ path ++ i ++ ")"

    handleEmpty "" = "^ro(6x6)"
    handleEmpty xs = xs

-- | Query each window in the 'WindowSet' and assign a symbol to it in a map.
queryWindows :: WindowSet -> [(String, Query Bool)] -> X (M.Map Window String)
queryWindows ws lm = do
    mapM (qw lm) (W.allWindows ws) >>= return . M.fromList
  where
    qw :: [(String, Query Bool)] -> Window -> X (Window, String)
    qw [] w           = return (w, defaultIcon)
    qw ((l, q):lqs) w = runQuery q w >>= if_ (return (w, l)) (qw lqs w)


-- | Map windows to symbols for the pager.  Symbols for floating windows are in
--   lower case.
windowLabelMap :: [(String, Query Bool)]
windowLabelMap =
    map whenFloat windows ++ windows
  where

    whenFloat (l, q) = (map toLower l, isFloat <&&> q)

    windows = zip (map icon apps) (map query apps)

lib/Panel.hs

------------------------------------------------------------------------------
-- |
-- Module      :  Dzen
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
--
-- Functions for spawning dzen instances.
--
------------------------------------------------------------------------------

module Panel
    ( spawnPanels
    , killPanels
    , getScreenCount
    ) where

-- Haskell modules
import Control.Monad
import Data.List
import Foreign.C.Types (CInt)
import GHC.IOBase (Handle)
import System.Cmd
import System.Environment (getEnv)
import System.Posix.Files(fileExist)

-- XMonad modules
import Control.Monad
import Graphics.X11.Xlib
import Graphics.X11.Xinerama
import XMonad
import XMonad.Util.Run(spawnPipe)

-- Custom modules
import Config
import Utils

-- | Run before each restart of xmonad to ensure that there
--   will only be the expected panel instances running.
killPanels :: X ()
killPanels = do
    spawn' "killall conky-cli"
    spawn' "killall hbar"
    spawn' "killall trayer"
    return ()

-- | Spawn the applications that make the upper panel.
spawnPanels :: IO ([Handle])
spawnPanels = do
    count <- getScreenCount'
    pipes <- mapM (spawnDzenOnScreen count) [0..count-1]
    spawnTrayer
    return pipes

spawnTrayer = spawn' $ intercalate " "
    [ "trayer"
    , "--edge"            , "top"
    , "--align"           , "right"
    , "--widthtype"       , "pixel"
    , "--width"           , show wTrayer
    , "--heighttype"      , "pixel"
    , "--height"          , height
    , "--margin"          , show $ wHbar + wConky
    , "--transparent"     , "true"
    , "--alpha"           , "0"
    , "--tint"            , convert $ defaultBG
    , "--SetDockType"     , "true"
    , "--SetPartialStrut" , "true"
    , "--expand"          , "true"
    ]
  where
    convert ('#':xs) = '0':'x':xs
    convert xs = xs

-- | spawn' two dzen instances at the top of the screen, reading input
--   from xmonad and hbar respectively.
spawnDzenOnScreen count screen = do

    -- Unfortunately, only one instance of trayer is allowed.
    let wTrayerMaybe = if screen == count - 1 then wTrayer else 0

    (sx, sy, sw, sh) <- getScreenDim screen
    pipes <- spawnPipe $ dzen
        sy              -- vertical position
        sx              -- horizontal position
        (sw - wHbar - wTrayerMaybe - wConky) -- horizontal width
        'l'             -- text align
        ""              -- no actions
    spawnDzenWithConky $ dzen
            sy          -- vertical position
            (sx + sw - wHbar - wConky)  -- horizontal position
            wConky      -- horizontal width
            'r'         -- text align
            ""          -- no actions
    spawn' $ hbar ++ dzen
        sy              -- vertical position
        (sx + sw - wHbar)  -- horizontal position
        wHbar              -- horizontal width
        'r'             -- text align
        ""              -- no actions
    return pipes

  where
    spawnDzenWithConky dest =
        fileExist conkyrc >>=
            (flip when $ do_ $ spawn' $ dzenWithConky conkyrc dest)

    dzenWithConky conkyrc dest = intercalate " " ["conky-cli -c", conkyrc, "|", dest]


-- | Return a string that launches dzen with the given configuration.
dzen :: Num a => a           -- ^ vertical position
              -> a           -- ^ horizontal position
              -> a           -- ^ horizontal width
              -> Char        -- ^ text align
              -> String      -- ^ actions
              -> String
dzen y x w ta e =
        intercalate " "
            [ "dzen2"
            , "-x"  , show x
            , "-w"  , show w
            , "-y"  , show y
            , "-h"  , height
            , "-fn" , quote font
            , "-bg" , quote defaultBG
            , "-fg" , quote defaultFG
            , "-ta" , [ta]
            , "-e"  , quote e
            ]

-- | Get the number of available screens.
getScreenCount :: Num a => X a
getScreenCount = io getScreenCount'

getScreenCount' :: Num a => IO a
getScreenCount' = do
    d <- openDisplay ""
    screens  <- getScreenInfo d
    return $ fromInteger $ toInteger $ length screens

-- | Return the dimensions (x, y, width, height) of screen n.
getScreenDim :: Num a => Int -> IO (a, a, a, a)
getScreenDim n = do
    d <- openDisplay ""
    screens  <- getScreenInfo d
    closeDisplay d
    let rn = screens!!(min (abs n) (length screens - 1))
    case screens of
        []        -> return $ (0, 0, 1024, 768) -- fallback
        [r]       -> return $ (fromIntegral $ rect_x r , fromIntegral $ rect_y r , fromIntegral $ rect_width r , fromIntegral $ rect_height r )
        otherwise -> return $ (fromIntegral $ rect_x rn, fromIntegral $ rect_y rn, fromIntegral $ rect_width rn, fromIntegral $ rect_height rn)

-- | Run the command in the background, ensuring that the
--   value returned is always 0. This is to avoid making
--   spawn break a sequence of commands due to a return
--   value indicating that an error has occured.
spawn' x = spawn $ x ++ "&"

lib/Utils.hs

------------------------------------------------------------------------------
-- |
-- Module      :  Utils
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
-- 
-- Utility functions for XMonad.
-- 
------------------------------------------------------------------------------

module Utils where

-- Haskell modules
import Control.Concurrent.MVar
import Control.Monad (unless, when, liftM)
import Control.Monad.Trans (lift)
import Data.List
import Data.Monoid (Endo(Endo))
import System.IO.Error (isDoesNotExistError)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Unistd(getSystemID, nodeName)
import qualified Data.Map as M

-- XMonad modules
import XMonad
import XMonad.Actions.CycleWS
import XMonad.Actions.Warp (warpToWindow)
import XMonad.Actions.WindowGo
import XMonad.Hooks.DynamicHooks (oneShotHook)
import XMonad.Hooks.FloatNext
import XMonad.Layout.IndependentScreens
import qualified XMonad.StackSet as W

-- Other moduls
import Graphics.X11.Xinerama
import Graphics.X11.Xlib.Extras


-- GENERAL

-- | Perform k x if x return a 'Just' value.
(?+) :: (Monad m) => m (Maybe a) -> (a -> m ()) -> m ()
x ?+ k = x >>= maybe (return ()) k
infixl 1 ?+

-- | Helper function for use with monads.
if_ :: t -> t -> Bool -> t
if_ t f c = if c 
                  then t
                  else f

-- | Change type to "m ()"
do_ :: (Monad m) => m a -> m ()
do_ x = x >> return ()

quote :: String -> String
quote x = "'" ++ x ++ "'"


-- WINDOW ACTIONS

-- | Swap the focused window with the last window in the stack.
swapBottom :: W.StackSet i l a s sd -> W.StackSet i l a s sd
swapBottom = W.modify' $ \c -> case c of
    W.Stack _ _ [] -> c    -- already bottom.
    W.Stack t ls rs -> W.Stack t (xs ++ x : ls) [] where (x:xs) = reverse rs

-- | Swap the focused window with the following window, or if the window is
--   floating, lower it to the bottom.
swapOrLower :: X ()
swapOrLower = withFocused $ \w ->
    runQuery isFloat w >>= if_ (windows swapBottom) (windows W.swapDown)

-- | Swap the focused window with the preceding window, or if the window is
--   floating, raise it to the top.
swapOrRaise :: X ()
swapOrRaise = withFocused $ \w ->
    runQuery isFloat w >>= if_ (windows W.swapMaster) (windows W.swapUp)

-- spawnOnThisWS :: GHC.IOBase.IORef XMonad.Hooks.DynamicHooks.DynamicHooks-> Query Bool-> String-> X ()
spawnOnThisWS dhr q cmd = withWindowSet $ \ws -> do
    oneShotHook dhr q $ doF $ W.shift $ W.currentTag ws
    spawn cmd

-- | Warp the mouse pointer to the focused window only if the workspace has
--   no floating windows to steal the focus.
warpToWindow' = withWindowSet $ \ws -> do
    let floats  = M.keys $ W.floating ws
        visible = W.integrate' $ W.stack $ W.workspace $ W.current ws
        vf      = floats `intersect` visible
    when (null vf) $ warpToWindow (1/2) (1/2)


-- QUERIES ETC

-- | Is the focused window the \"master window\" of the current workspace?
isMaster :: Query Bool
isMaster = ask >>= (\w -> liftX $ withWindowSet $ \ws -> return $ Just w == master ws)
  where
    master :: WindowSet -> Maybe Window
    master ws = 
        case W.integrate' $ W.stack $ W.workspace $ W.current ws of
             [] -> Nothing
             (x:xs) -> Just x

-- | Is the focused window a floating window?
isFloat :: Query Bool
isFloat = ask >>= (\w -> liftX $ withWindowSet $ \ws -> return $ M.member w $ W.floating ws)

-- | Helper to read a property
-- getProp :: Atom -> Window -> X (Maybe [CLong])
getProp a w = withDisplay $ \dpy -> io $ getWindowProperty32 dpy a w

-- | Check if window is DIALOG window
checkDialog :: Query Bool
checkDialog = ask >>= \w -> liftX $ do
                a <- getAtom "_NET_WM_WINDOW_TYPE"
                dialog <- getAtom "_NET_WM_WINDOW_TYPE_DIALOG"
                mbr <- getProp a w
                case mbr of
                  Just [r] -> return $ elem (fromIntegral r) [dialog]
                  _ -> return False

-- | Determine the number of physical screens.
countScreens :: (MonadIO m, Integral i) => m i
countScreens = liftM genericLength . liftIO $ openDisplay "" >>= getScreenInfo


-- HOST

-- | For use in cross host configutions.
data Host = Laptop | Netbook deriving Eq

-- | Determine the host.
getHost = do 
    host <- getSystemID
    case nodeName host of
         "mntnoe-laptop"  -> return Laptop
         "mntnoe-netbook" -> return Netbook
         _                -> return Laptop


-- MISC

-- | Return a string that launches xterm with the given 'title', 'appName' and
--   command to execute.
xterm :: String -> String -> String
xterm a e = concat ["xterm -wf -title '", e,  "' -name '", a, "' -e '", e, "'"]

lib/Workspace.hs

------------------------------------------------------------------------------
-- |
-- Module      :  Workspace 
-- Copyright   :  (c) Mads N Noe 2010
-- Maintainer  :  mail (@) madsnoe.dk
-- License     :  as-is
-- 
-- Workspace actions.
-- 
------------------------------------------------------------------------------

module Workspace where

-- Haskell modules
import Data.Maybe ( isNothing, isJust )

-- XMonad modules
import XMonad
import XMonad.Actions.CycleWS
import XMonad.Util.WorkspaceCompare (getSortByTag)
import qualified XMonad.StackSet as W

-- Custom modules
import App
import Config
import Utils

-- | Shift a window to a workspace and switch to that workspace in one
--   operation.
shiftView :: WorkspaceId -> WindowSet -> WindowSet
shiftView id ws = shiftView' id ws
  where
    shiftView' id ws = W.greedyView id $ W.shift id ws

shiftViewUngreedy id ws = shiftView' id ws
  where
    shiftView' id ws = W.view id $ W.shift id ws

-- | Perform a workspace transformation on the next workspace in 'WSDirection'
--   of type 'WSType'.
doWithWS :: (String -> (WindowSet -> WindowSet)) -> Direction1D -> WSType -> X ()
doWithWS f dir wstype = do
    i <- findWorkspace getSortByTag dir (WSIs pred) 1
    windows $ f i
  where
    pred = do
        hidden <- isHidden
        return $ (\ws -> notSummon ws && notHidden ws && isWsType ws && hidden ws)

    notSummon ws = W.tag ws /= (summonWorkspaceTag)
    notHidden ws = W.tag ws /= (hiddenWorkspaceTag)

    isWsType ws = wsTypeToPred wstype ws

    wsTypeToPred EmptyWS    = isNothing . W.stack
    wsTypeToPred NonEmptyWS = isJust . W.stack
    wsTypeToPred _          = const False

    isHidden = do
        hs <- gets (map W.tag . W.hidden . windowset)
        return (\ws -> W.tag ws `elem` hs)

-- | Swap workspace contents with next screen and focus it. Useful when you work on
--   a laptop with an external screen and keyboard, and want to switch between them.
swapNextScreen' :: X ()
swapNextScreen' = do 
    ws <- gets windowset
    screenWorkspace (nextScreen ws) ?+ windows . swap (W.currentTag ws)

  where

    nextScreen ws = (W.screen (W.current ws) + 1) 
                    `mod` 
                    fromIntegral (length (W.screens ws))

    swap f t = W.view f . W.greedyView t