xmonad.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts, NoMonomorphismRestriction #-}
-- config description
--
import XMonad
import XMonad.Config.Gnome
import XMonad.Hooks.DynamicLog 
import XMonad.Hooks.ManageDocks
import XMonad.Hooks.ManageHelpers
import XMonad.Hooks.FadeInactive
import XMonad.Hooks.EwmhDesktops (ewmh)
import XMonad.Util.Run
import XMonad.Util.EZConfig
import XMonad.Util.Scratchpad
import XMonad.Util.NamedScratchpad
import XMonad.Util.WindowProperties
import XMonad.Actions.CycleWS
import XMonad.Actions.WindowGo
import XMonad.Layout.Combo
import XMonad.Layout.Grid
import XMonad.Layout.LayoutModifier
import XMonad.Layout.Named
import XMonad.Layout.NoBorders
import XMonad.Layout.PerWorkspace
import XMonad.Layout.Reflect
import XMonad.Layout.TwoPane
import XMonad.Layout.WindowNavigation
import Data.Ratio
import DBus
import DBus.Connection
import DBus.Message
import Control.OldException
import Control.Monad
import qualified XMonad.StackSet as S
import qualified Data.Map as M
 
-- scratchpads
scratchpads = 
    [ NS "console" "urxvt -title console" (title =? "console") (customFloating $ S.RationalRect 0 (3/5) 1 (2/5))
    -- , 
    -- NS "browser" "chromium" (className =? "Chromium") (customFloating $ S.RationalRect (1/10) (1/20) (4/5) (9/10))
    -- , NS "TODO" "gvim --role TODO ~/TODO" (role =? "TODO") nonFloating
    ] where role = stringProperty "WM_WINDOW_ROLE"

-- workspaces
myWorkspaces = ["web", "vim", "terminal", "devel", "files", "im", "irc", "music", "gfx", "virtual", "fullscreen"]

-- layouts
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
gridLayout = named "grid" $ avoidStruts $ Grid
fullscreenLayout = named "fullscreen" $ noBorders Full
imLayout = named "im" $ avoidStruts $ reflectHoriz $ withIMs ratio rosters chatLayout where
    chatLayout      = Grid
    ratio           = 1%6
    rosters         = [skypeRoster, empathyRoster]
    empathyRoster   = And (ClassName "Empathy") (Role "contact_list")
--    pidginRoster    = And (ClassName "Pidgin") (Role "buddy_list")
    skypeRoster     = (ClassName "Skype") `And` (Not (Title "Options")) `And` (Not (Role "Chats")) `And` (Not (Role "CallWindowForm"))
 
myLayoutHook = smartBorders $ fullscreen $ im $ normal where
    normal     = tallLayout ||| wideLayout ||| singleLayout ||| gridLayout
    fullscreen = onWorkspace "fullscreen" fullscreenLayout
    im         = onWorkspace "im" imLayout
 
-- hooks
myManageHook = composeAll 
    [ (className =? "file-roller" <&&> title =? "Rozpakowywanie plików z archiwum") --> doFloat
    , (className =? "Gnome-panel" <&&> title =? "Uruchom program") --> doFloat
    , (className =? "VirtualBox") --> doFloat
    , (className =? "Sonata") --> doFloat
    , (className =? "Tomboy") --> doFloat
    , (className =? "Revelation") --> doFloat
    , (className =? "Keepassx") --> doFloat
    , (className =? "fontforge" <&&> title =? "Narzędzia") --> doFloat
    , (className =? "fontforge" <&&> title =? "Warstwy") --> doFloat
    , (title =? "Do") --> doIgnore
    , (className =? "Cardapio") --> doFloat
    , (className =? "Download") --> doFloat
    , (className =? "VirtualBox") --> doShift "virtual"
--    , (className =? "Thunderbird") --> doShift "mail"
    , (className =? "Gvim") --> viewShift "vim"
    , (className =? "Skype") --> doShift "im"
    , (className =? "Nautilus") --> viewShift "files"
    , (className =? "Pidgin") --> doShift "im"
    , (className =? "Empathy") --> doShift "im"
    , (className =? "Firefox") --> doShift "web"
    , (className =? "Namoroka") --> doShift "web"
    , (className =? "Chromium-browser") --> doShift "web"
    , (className =? "Rhythmbox") --> doShift "music"
    , (className =? "Totem") --> doShift "fullscreen"
    -- , (className =? "Gnome-terminal") --> doShift "terminal"
    , isDialog --> doCenterFloat
    , isFullscreen --> doFullFloat
    , isIM --> viewShift "im" -- moveToIM
    ] 
  where 
    viewShift = doF . liftM2 (.) S.greedyView S.shift
    role = stringProperty "WM_WINDOW_ROLE"
    isIM     = foldr1 (<||>) [isPidgin, isSkype, isEmpathy]
    isPidgin = className =? "Pidgin"
    isEmpathy = className =? "Empathy" <||> role =? "chat"
    isSkype  = className =? "Skype"
    moveToIM = doF $ S.shift "im"

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 ()

fadeMostInactives :: Rational -> X ()
fadeMostInactives = fadeOutLogHook . fadeIf (isUnfocused <&&> noneOf qs)
  where noneOf = fmap not . foldr1 (<||>)
        qs = [isFullscreen, className =? "Cardapio", className =? "Gimp"]

onAllEvents :: PP -> X ()
onAllEvents pp = do
  fadeMostInactives 0.95
  dynamicLogWithPP pp

main :: IO ()
main = withConnection Session $ \ dbus -> do
  putStrLn "Getting well-known name."
  getWellKnownName dbus
  putStrLn "Got name, starting XMonad."
  spawn "xcompmgr"
  xmonad $ ewmh $ gnomeConfig 
    { manageHook = myManageHook <+> namedScratchpadManageHook scratchpads <+> manageHook gnomeConfig
    , layoutHook = myLayoutHook
    , modMask = mod1Mask -- mod4Mask
    , terminal = "x-terminal-emulator"
    , borderWidth = 1
    , normalBorderColor = "#1f1f1f" --"#A9B7C4"
    , focusedBorderColor = "#A9C3D9" --"#247EB3"
    , workspaces = myWorkspaces
    , logHook = onAllEvents $ defaultPP
      { ppOutput   = \ str -> do
           let str'  = str
               str'' = str'
           msg <- newSignal "/org/xmonad/Log" "org.xmonad.Log" 
                      "Update"
           addArgs msg [String str'']
           -- If the send fails, ignore it.
           send dbus msg 0 `catchDyn`
             (\ (DBus.Error _name _msg) ->
               return 0)
           return ()
       -- , ppTitle    = pangoFont "Gill Sans MT Pro Bold 11" . pangoColor "#000000" . shorten 100
       -- , ppTitle    = pangoFont "Ubuntu Bold 10" . pangoColor "#000000" . shorten 100
       , ppTitle    = pangoFont "Ubuntu Bold 10" . pangoColor "#ffffff" . shorten 100
       , ppCurrent  = pangoColor "#247EB3" . wrap "[" "]"
       , ppVisible  = pangoColor "#4D4D4D" . wrap "(" ")"
       , ppHidden   = wrap " " " "
       , ppUrgent   = pangoColor "red"
       , ppSort     = fmap (.namedScratchpadFilterOutWorkspace) $ ppSort defaultPP
      } 
    }
    `additionalKeysP`
    [ ("<Print>", spawn "scrot")
    , ("C-<Print>", spawn "sleep 0.2; scrot -s")
    , ("C-M-<Left>", prevWS )
    , ("C-M-<Right>", nextWS )
    , ("C-M-S-<Left>", shiftToPrev )
    , ("C-M-S-<Right>", shiftToNext )
    , ("M-x", runOrRaiseNext "x-terminal-emulator" (className =? "Gnome-terminal"))
    , ("M-f", runOrRaise "x-www-browser" (className =? "Minefield" <||> className =? "Namoroka" <||> className =? "Chromium-browser"))
    , ("M-n", spawn "wmctrl -xa nautilus || nautilus")
    , ("M-g", spawn "wmctrl -xa gvim || gvim")
    , ("M-S-q", spawn "gnome-session-save --gui --shutdown-dialog")
    , ("M-<F4>", kill)
    , ("M-r", gnomeRun)
--  , ("M-`", namedScratchpadAction scratchpads "console")
--  , ("M-=", namedScratchpadAction scratchpads "browser")
    ]

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>"

-- modified version of XMonad.Layout.IM --
--
-- | Data type for LayoutModifier which converts given layout to IM-layout
-- (with dedicated space for the roster and original layout for chat windows)
data AddRosters a = AddRosters Rational [Property] deriving (Read, Show)
 
instance LayoutModifier AddRosters Window where
  modifyLayout (AddRosters ratio props) = applyIMs ratio props
  modifierDescription _                = "IMs"
 
-- | Modifier which converts given layout to IMs-layout (with dedicated
-- space for rosters and original layout for chat windows)
withIMs :: LayoutClass l a => Rational -> [Property] -> l a -> ModifiedLayout AddRosters l a
withIMs ratio props = ModifiedLayout $ AddRosters ratio props
 
-- | IM layout modifier applied to the Grid layout
gridIMs :: Rational -> [Property] -> ModifiedLayout AddRosters Grid a
gridIMs ratio props = withIMs ratio props Grid
 
hasAnyProperty :: [Property] -> Window -> X Bool
hasAnyProperty [] _ = return False
hasAnyProperty (p:ps) w = do
    b <- hasProperty p w
    if b then return True else hasAnyProperty ps w
 
-- | Internal function for placing the rosters specified by
-- the properties and running original layout for all chat windows
applyIMs :: (LayoutClass l Window) =>
               Rational
            -> [Property]
            -> S.Workspace WorkspaceId (l Window) Window
            -> Rectangle
            -> X ([(Window, Rectangle)], Maybe (l Window))
applyIMs ratio props wksp rect = do
    let stack = S.stack wksp
    let ws = S.integrate' $ stack
    rosters <- filterM (hasAnyProperty props) ws
    let n = fromIntegral $ length rosters
    let (rostersRect, chatsRect) = splitHorizontallyBy (n * ratio) rect
    let rosterRects = splitHorizontally n rostersRect
    let filteredStack = stack >>= S.filter (`notElem` rosters)
    wrs <- runLayout (wksp {S.stack = filteredStack}) chatsRect
    return ((zip rosters rosterRects) ++ fst wrs, snd wrs)