xmonad.hs

import XMonad
import XMonad.Config.Gnome
import XMonad.Hooks.DynamicLog
import XMonad.Hooks.ManageDocks
import XMonad.Hooks.ManageHelpers
import XMonad.Actions.CycleWS
import XMonad.Actions.WindowGo
import XMonad.Util.WindowProperties
import XMonad.Util.EZConfig
import XMonad.Layout.Named
import XMonad.Layout.NoBorders
-- import Control.Monad(liftM2)
import Control.OldException
import DBus
import DBus.Connection
import DBus.Message
-- import qualified XMonad.StackSet as S
-- import qualified Data.Map as M

basicLayout = Tall nmaster delta ratio where
    nmaster = 1
    delta   = 3/100
    ratio   = 1/2

tallLayout = named "tall" $ avoidStruts $ basicLayout
wideLayout = named "wide" $ avoidStruts $ Mirror basicLayout
singleLayout = named "single" $ avoidStruts $ noBorders Full

myLayoutHook = smartBorders $ normal where
    normal = tallLayout ||| wideLayout ||| singleLayout

myWorkspaces = ["1:web", "2:vim", "3:terminal", "4:irc", "5:music"]

myManageHook = composeAll 
    [ (className =? "Gvim") --> doShift "2:vim"
    , (className =? "Google-chrome") --> doShift "1:web"
    , (className =? "Rhythmbox") --> doShift "5:music"
    -- , (className =? "Gnome-terminal") --> doShift "3:terminal"
    , isDialog --> doCenterFloat
    , isFullscreen --> doFullFloat
    ]
  where 
    -- viewShift = doF . liftM2 (.) S.greedyView S.shift
    role = stringProperty "WM_WINDOW_ROLE"

main :: IO ()
main =  withConnection Session $ \dbus -> do
    getWellKnownName dbus
    -- spawn "xcompmgr"
    xmonad $ gnomeConfig
        { manageHook = myManageHook <+> manageHook gnomeConfig
        , borderWidth = 1
        , modMask = mod1Mask -- mod4Mask
        , normalBorderColor =  "#000000"
        , focusedBorderColor = "#666666"
        , workspaces = myWorkspaces 
        , logHook = dynamicLogWithPP (prettyPrinter dbus)
        , layoutHook = myLayoutHook
        }
        `additionalKeysP`
        [ ("C-M-<Left>", prevWS )
        , ("C-M-<Right>", nextWS )
        , ("C-M-S-<Left>", shiftToPrev )
        , ("C-M-S-<Right>", shiftToNext )
        , ("M-x", runOrRaiseNext "gnome-terminal" (className =? "Gnome-terminal"))
        , ("M-f", runOrRaise "google-chrome" (className =? "Google-chrome"))
        , ("M-g", runOrRaise "gvim" (className =? "Gvim"))
        , ("C-q", kill)
        ]

prettyPrinter :: Connection -> PP
prettyPrinter dbus = defaultPP
    { ppOutput          = dbusOutput dbus
    , ppTitle           = pangoColor "#F0F0F0" . pangoSanitize . shorten 100
    , ppUrgent          = pangoColor "red"
    , ppLayout          = const ""
    , ppSep             = "  "
    , ppCurrent         = pangoColor "#49A2EA" . wrap " " " "
    , ppVisible         = pangoColor "#F0F0F0" . wrap " " " "
    , ppHidden          = wrap " " " "
    , ppHiddenNoWindows = wrap " " " "
    }

getWellKnownName :: Connection -> IO ()
getWellKnownName dbus = tryGetName `catchDyn` (\(DBus.Error _ _) -> getWellKnownName dbus)
  where
    tryGetName = do
        namereq <- newMethodCall serviceDBus pathDBus interfaceDBus "RequestName"
        addArgs namereq [String "org.xmonad.Log", Word32 5]
        sendWithReplyAndBlock dbus namereq 0
        return ()

dbusOutput :: Connection -> String -> IO ()
dbusOutput dbus str = do
    msg <- newSignal "/org/xmonad/Log" "org.xmonad.Log" "Update"
    addArgs msg [String ("<b>" ++ str ++ "</b>")]
    -- If the send fails, ignore it.
    send dbus msg 0 `catchDyn` (\(DBus.Error _ _) -> return 0)
    return ()

pangoColor :: String -> String -> String
pangoColor fg = wrap left right
  where
    left  = "<span foreground=\"" ++ fg ++ "\">"
    right = "</span>"

pangoFont :: String -> String -> String
pangoFont font = wrap left right
 where
  left  = "<span font=\"" ++ font ++ "\">"
  right = "</span>"

pangoSanitize :: String -> String
pangoSanitize = foldr sanitize ""
  where
    sanitize '>'  xs = "&gt;" ++ xs
    sanitize '<'  xs = "&lt;" ++ xs
    sanitize '\"' xs = "&quot;" ++ xs
    sanitize '&'  xs = "&amp;" ++ xs
    sanitize x    xs = x:xs