xmonad.hs

import Control.OldException(catchDyn,try)
    
import DBus
import DBus.Connection
import DBus.Message

import XMonad
import XMonad.Config.Gnome
import XMonad.Util.EZConfig
import XMonad.Hooks.DynamicLog
import XMonad.Hooks.SetWMName

main = withConnection Session $ \dbus -> do
         getWellKnownName dbus
         xmonad $ gnomeConfig
                    { modMask = mod4Mask
                    , terminal = "gnome-terminal --hide-menubar"
                    , normalBorderColor  = "#000000"
                    , focusedBorderColor = "#999999"
                    , borderWidth = 2
                    , logHook = dynamicLogWithPP (myPrettyPrinter dbus)
                    , startupHook = setWMName "LG3D"
                    }
                    `additionalKeysP`
                    [ ("M-S-o", spawn "chromium-browser")
                    , ("M-S-p", spawn "emacsclient -c")
                    , ("M-S-w", spawn "lock-and-suspend")
                    , ("M-S-d", spawn "switch-displays")
                    , ("M-S-q", spawn "gnome-session-save --gui --logout-dialog")
                    , ("M-`", spawn "switch-keyboards.sh")
                    , ("M-r", gnomeRun)
                    ]

-- This retry is really awkward, but sometimes DBus won't let us get our
-- name unless we retry a couple times.
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 ()
            
myPrettyPrinter :: Connection -> PP
myPrettyPrinter dbus = defaultPP {
    ppOutput  = outputThroughDBus dbus
  , ppTitle   = pangoColor "#0099BB" . shorten 50 . pangoSanitize
  , ppCurrent = pangoColor "#008888" . wrap "[" "]" . pangoSanitize
  , ppVisible = pangoColor "#663366" . wrap "(" ")" . pangoSanitize
  , ppHidden  = wrap " " " "
  , ppUrgent  = pangoColor "red"
  }

outputThroughDBus :: Connection -> String -> IO ()
outputThroughDBus dbus str = do
  let str' = "<span font=\"Terminus 9 Bold\">" ++ str ++ "</span>"
  msg <- newSignal "/org/xmonad/Log" "org.xmonad.Log" "Update"
  addArgs msg [String str']
  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>"

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