gistfile1.txt

{- # OPTIONS_GHC -fglasgow-exts    #-} -- For deriving Data/Typeable
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances, DeriveDataTypeable #-}

import IO
import Control.Monad
import Control.OldException(catchDyn,try)
import XMonad.Util.Run
import Control.Concurrent
import DBus
import DBus.Connection
import DBus.Message
import System.Cmd
import XMonad hiding ((|||))
import XMonad.Operations
import XMonad.Config.Kde
import qualified XMonad.StackSet as W
import XMonad.Util.EZConfig
import XMonad.Actions.FindEmptyWorkspace
import XMonad.Config.Desktop
import XMonad.Layout hiding ((|||))
import XMonad.Layout.Tabbed
import XMonad.Layout.ThreeColumns
import XMonad.Actions.CycleWS
import XMonad.Layout.NoBorders
import XMonad.Layout.Combo
import XMonad.Layout.Grid
import XMonad.Layout.TwoPane
import XMonad.Layout.WindowNavigation
import XMonad.Layout.IM
import XMonad.Layout.ToggleLayouts
import XMonad.Actions.WindowBringer
import Data.Int
import Data.List
import Data.List.Utils (split)
import Data.Ratio
import Data.Maybe
import Data.Monoid
import qualified Data.HashTable as H
import XMonad.Actions.GridSelect
import XMonad.Hooks.ManageDocks
import XMonad.Hooks.DynamicLog
import XMonad.Util.WorkspaceCompare
import XMonad.Layout.Named
import XMonad.Actions.Plane
import XMonad.Layout.LayoutCombinators ((|||))
import XMonad.Actions.CycleSelectedLayouts
import XMonad.Actions.Warp
import XMonad.Actions.Promote
import XMonad.Hooks.UrgencyHook
import XMonad.Util.XUtils (fi)
import XMonad.Util.WindowProperties (getProp32, getProp32s)
import qualified XMonad.Util.ExtensibleState as XS
import Char

myWorkspaces = ["q", "w", "e", "a", "s", "d", "y", "x", "c"]

myLayout = (desktopLayoutModifiers $ tiledN ||| tiled ||| mtiled ||| tab ||| chat) ||| ffull
  where
     tiledN  = named "tl" $ TallNoMax 1 (3/100) (0.51)
     tiled   = named "TL" $ Tall 1 (3/100) (0.51)
     mtiled  = named "hz" $ Mirror $ Tall 1 (3/100) (0.51)
     tab     = named "tab" $ simpleTabbed
     chat    = named "IM" $ withIM (0.5) (ClassName "Konversation") twotabs
     twotabs = windowNavigation $
               combineTwo (Mirror $ TwoPane 0.03 0.5) simpleTabbed (TwoPane 0.03 0.5)
     ffull   = named "fu" $ noBorders $ Full

hashWin :: Window -> Int32
hashWin = H.hashInt . fromIntegral

main = withConnection Session $ \ dbus -> do
  getWellKnownName dbus
  pidhash <- H.new (==) H.hashInt
  winhash <- H.new (==) hashWin
  (xmonad
   $ withUrgencyHook NoUrgencyHook
   $ kde4Config {
      modMask = mod4Mask -- use the Windows button as mod
      , manageHook = pidManageHook pidhash winhash <+> manageHook kde4Config <+> myManageHook <+> doF W.shiftMaster
      , handleEventHook = handleEventHook kde4Config <+> attentionEventHook <+> pidEventHook pidhash winhash
      , workspaces = myWorkspaces
      , layoutHook = myLayout
      , logHook = logHook kde4Config >> dynamicLogWithPP (myPrettyPrinter dbus)
      , borderWidth = 2
      }
   `removeKeysP` [ "M-"++n | n <- map show [3..9 :: Int] ]
   `additionalKeys` [((mod4Mask, xK_section), swapNextScreen)]
   `additionalKeysP` myKeys
   `additionalMouseBindings`
   [ ((mod4Mask, button1), (\w -> focus w >> windows W.swapMaster))
   , ((mod4Mask, button2), (\w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster))
   , ((mod4Mask, button3), (\w -> focus w >> mouseResizeWindow w))
   , ((mod4Mask, button4), (\_ -> windows W.focusUp ))
   , ((mod4Mask, button5), (\_ -> windows W.focusDown))
   ])
 where
   myManageHook = composeAll . concat $
     [ [ className   =? c --> doFloat           | c <- myFloats]
     , [ title       =? t --> doFloat           | t <- myOtherFloats]
     , [ className   =? c --> doF (W.shift "w") | c <- mailApps]
     , [ className   =? c --> doF (W.shift "c") | c <- ircApps]
     , [ (fmap ("kmail-composer" `isPrefixOf`) role) --> doF (W.shift "q") ]
     , [ liftX (gets (W.currentTag . windowset)) =? "w" <&&> className =? c --> doShift "e" | c <- webApps ]
     ]
   myFloats      = ["MPlayer", "Gimp", "krunner", "Nvidia-settings", "Plasma-desktop"]
   myOtherFloats = ["alsamixer", "Password – KDE Dæmon"]
   mailApps      = ["Kontact"]
   webApps       = ["Firefox", "Conkeror"] -- open on desktop 3
   ircApps       = ["Konversation", "Skype", "Kopete"] -- open on desktop 9
   role          = stringProperty "WM_WINDOW_ROLE"

myKeys = [
   ("M-<Return>", promote)
 , ("M-v", kill)
 , ("M-'", spawn "xmonad --recompile && xmonad --restart")
 , ("M-1", screenWorkspace 0 >>= flip whenJust (windows . W.view))
 , ("M-2", screenWorkspace 1 >>= flip whenJust (windows . W.view))
 , ("M-o", nextScreen)
 , ("M-S-1", screenWorkspace 0 >>= flip whenJust (windows . W.shift))
 , ("M-S-2", screenWorkspace 1 >>= flip whenJust (windows . W.shift))
 , ("M-r M-f", spawn "conkeror")
 , ("M-r M-g", spawn "conkeror")
 , ("M-r M-r", spawn "konsole")
 , ("M-r M-<Space>", spawn "qdbus org.kde.krunner /App org.kde.krunner.App.display")
 , ("M-<Space>", spawn "qdbus org.kde.krunner /App org.kde.krunner.App.display")
 , ("M-r M-d", spawn "digikam")
 , ("M-r M-l", spawn "dolphin")
 , ("M-f M-f", withFocused float )
 , ("M-f M-t", withFocused $ windows . W.sink )
 , ("M-0", refresh)
 , ("M-<U>", sendMessage $ Move U)
 , ("M-<D>", sendMessage $ Move D)
 , ("M-<R>", sendMessage $ Move R)
 , ("M-<L>", sendMessage $ Move L)
 , ("M-n", viewEmptyWorkspace)
 , ("S-M-n", tagToEmptyWorkspace)
 , ("M-g", gotoMenu)
 , ("M-b", bringMenu)
 , ("M-S-b", sendMessage ToggleStruts)
 , ("M-<F1>", cycleThroughLayouts ["tl"])
 , ("M-<F2>", cycleThroughLayouts ["TL"])
 , ("M-<F3>", cycleThroughLayouts ["hz"])
 , ("M-<F4>", cycleThroughLayouts ["tab"])
 , ("M-<F5>", cycleThroughLayouts ["IM"])
 , ("M-<F6>", cycleThroughLayouts ["fu"])
 , ("M-t", warpToWindow (1%2) (1%2))
 , ("M-u", focusUrgent)
 ] ++ [ ("M-" ++ w, windows $ W.greedyView w) | w <- myWorkspaces ]
         ++ [ ("S-M-" ++ w, windows $ W.shift w) | w <- myWorkspaces ]

-- | The builtin tiling mode of xmonad. Supports 'Shrink', 'Expand' and
-- 'IncMasterN'.
data TallNoMax a = TallNoMax { tallNMaster :: !Int               -- ^ The default number of windows in the master pane (default: 1)
                   , tallRatioIncrement :: !Rational   -- ^ Percent of screen to increment by when resizing panes (default: 3/100)
                   , tallRatio :: !Rational }          -- ^ Default proportion of screen occupied by master pane (default: 1/2)
                deriving (Show, Read)

-- a nice pure layout, lots of properties for the layout, and its messages, in Properties.hs
instance LayoutClass TallNoMax a where
    pureLayout (TallNoMax nmaster _ frac) r s = zip ws rs
      where ws = W.integrate s
            rs = tileNoMax frac r nmaster (length ws)

    pureMessage (TallNoMax nmaster delta frac) m =
            msum [fmap resize     (fromMessage m)
                 ,fmap incmastern (fromMessage m)]

      where resize Shrink             = TallNoMax nmaster delta (max 0 $ frac-delta)
            resize Expand             = TallNoMax nmaster delta (min 1 $ frac+delta)
            incmastern (IncMasterN d) = TallNoMax (max 0 (nmaster+d)) delta frac

    description _ = "TallNoMax"

-- | Compute the positions for windows using the default two-pane tiling
-- algorithm.
--
-- The screen is divided into two panes. All clients are
-- then partioned between these two panes. One pane, the master, by
-- convention has the least number of windows in it.
tileNoMax
    :: Rational  -- ^ @frac@, what proportion of the screen to devote to the master area
    -> Rectangle -- ^ @r@, the rectangle representing the screen
    -> Int       -- ^ @nmaster@, the number of windows in the master pane
    -> Int       -- ^ @n@, the total number of windows to tileNoMax
    -> [Rectangle]
tileNoMax f r nmaster n =
    splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 -- two columns
  where (r1,r2) = splitHorizontallyBy f r


myPrettyPrinter :: Connection -> PP
myPrettyPrinter dbus = defaultPP {
    ppOutput = outputThroughDBus dbus
  , ppTitle = \x -> x
  , ppCurrent = wrap "[" "]" . bold . pangoSanitize
  , ppVisible = bold
  , ppHidden = pangoSanitize
  , ppHiddenNoWindows = \x -> ""
  , ppUrgent = wrap "" "!" . bold . map toUpper
  , ppOrder = \(ws:layout:_:_) -> [ws,layout]
  , ppSep = " &ndash; "
  , ppSort = mkWsSort getXineramaWsCompare
  }
  where
    bold = wrap "<span style=\"font-weight: bold;\">" "</span>"


debugPrint :: String -> IO ()
--debugPrint = appendFile "/tmp/xmonad-debug"
debugPrint _ = return ()

knownPid :: H.HashTable Int Window -> Int -> IO (Maybe Window)
knownPid pidhash pid = do
  found <- H.lookup pidhash pid
  case found of
    Just w -> do
              debugPrint $ "knownPid true in first case " ++ (show pid) ++ "\n"
              return $ Just w
    _      -> do ppid <- getppid pid
                 debugPrint $ "knownPid ppid is " ++ (show ppid) ++ "\n"
                 if ppid == pid || ppid <= 1
                   then return Nothing
                   else knownPid pidhash ppid

getppid :: Int -> IO Int
getppid pid = catch (do stat <- readFile $ "/proc/" ++ (show pid) ++ "/stat"
                        let (_:_:_:ppidstr:_) = split " " stat
                          in return $ read ppidstr)
              (\e -> return 1)

hasPid :: H.HashTable Int Window -> Query (Maybe Window)
hasPid pidhash = ask >>= \w -> liftX $ do
  pid <- getProp32s "_NET_WM_PID" w
  io $ debugPrint $ "hasPid " ++ (show pid) ++ "\n"
  case pid of
    Just [p] -> io $ knownPid pidhash (fromIntegral p)
    _ -> return Nothing

pidManageHook :: H.HashTable Int Window -> H.HashTable Window Int -> ManageHook
pidManageHook pidhash winhash = do
  interesting <- hasPid pidhash
  case interesting of
    Just parent -> do
         pdesk <- liftX $ gets (W.findTag parent . windowset)
         case pdesk of
           Just d -> do ask >>= \w -> liftX $ flagUrgent w
                        doF $ W.shift d
           _ -> idHook
    _ -> idHook

isPidInteresting :: Query Bool
isPidInteresting = className =? "Konsole"

updatePid :: H.HashTable Int Window -> H.HashTable Window Int -> Window -> X ()
updatePid pidhash winhash w = do
  pid <- getProp32s "_NET_WM_PID" w
  io $ debugPrint $ "updatePid " ++ (show pid) ++ "\n"
  case pid of
    Just [p] -> do 
      _ <- io $ H.update pidhash (fromIntegral p) w
      _ <- io $ H.update winhash w (fromIntegral p)
      return ()
    _        -> return ()

removePid :: H.HashTable Int Window -> H.HashTable Window Int -> Window -> X ()
removePid pidhash winhash w = do
  pid <- io $ H.lookup winhash w
  io $ debugPrint $ "removePid " ++ (show pid) ++ "\n"
  case pid of
    Just p -> do 
      _ <- io $ H.delete winhash w
      _ <- io $ H.delete pidhash (fromIntegral p)
      return ()
    _        -> return ()

pidEventHook :: H.HashTable Int Window -> H.HashTable Window Int -> Event -> X All
pidEventHook pidhash winhash (MapNotifyEvent {ev_window = w}) = do
  whenX (runQuery isPidInteresting w) (updatePid pidhash winhash w)
  return $ All True
pidEventHook pidhash winhash (DestroyWindowEvent {ev_window = w}) = do
  removePid pidhash winhash w
  return $ All True
pidEventHook pidhash winhash _ = return $ All True

-- -----------------------------------------------------------------------------

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

outputThroughDBus :: Connection -> String -> IO ()
outputThroughDBus dbus str = do
  let str' = "<span style=\"font-size: 12pt\">" ++ 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

flagUrgent :: Window -> X ()
flagUrgent win = adjustUrgents (\ws -> if elem win ws then ws else win : ws)

attentionEventHook :: Event -> X All
attentionEventHook (ClientMessageEvent _ _ _ dpy win typ (action:dats)) = do
  state <- getAtom "_NET_WM_STATE"
  attention <- getAtom "_NET_WM_STATE_DEMANDS_ATTENTION"
  wstate <- fromMaybe [] `fmap` getProp32 state win

  let isFull = fromIntegral attention `elem` wstate

      -- Constants for the _NET_WM_STATE protocol:
      remove = 0
      add = 1
      toggle = 2
      ptype = 4 -- The atom property type for changeProperty
      chWstate f = io $ changeProperty32 dpy win state ptype propModeReplace (f wstate)

  when (typ == state && fi attention `elem` dats) $ do
    when (action == add || (action == toggle && not isFull)) $ do
      flagUrgent win
      userCodeDef () =<< asks (logHook . config)
    when (action == remove || (action == toggle && isFull)) $ do
      clearUrgency win
      userCodeDef () =<< asks (logHook . config)

  return $ All True

attentionEventHook _ = return $ All True