Don't like ads? PRO users don't see any ads ;-)
Public Pastes
Guest

Untitled

By: a guest on May 15th, 2012  |  syntax: None  |  size: 13.25 KB  |  hits: 14  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. {- # OPTIONS_GHC -fglasgow-exts    #-} -- For deriving Data/Typeable
  2. {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances, DeriveDataTypeable #-}
  3.  
  4. import IO
  5. import Control.Monad
  6. import Control.OldException(catchDyn,try)
  7. import XMonad.Util.Run
  8. import Control.Concurrent
  9. import DBus
  10. import DBus.Connection
  11. import DBus.Message
  12. import System.Cmd
  13. import XMonad hiding ((|||))
  14. import XMonad.Operations
  15. import XMonad.Config.Kde
  16. import qualified XMonad.StackSet as W
  17. import XMonad.Util.EZConfig
  18. import XMonad.Actions.FindEmptyWorkspace
  19. import XMonad.Config.Desktop
  20. import XMonad.Layout hiding ((|||))
  21. import XMonad.Layout.Tabbed
  22. import XMonad.Layout.ThreeColumns
  23. import XMonad.Actions.CycleWS
  24. import XMonad.Layout.NoBorders
  25. import XMonad.Layout.Combo
  26. import XMonad.Layout.Grid
  27. import XMonad.Layout.TwoPane
  28. import XMonad.Layout.WindowNavigation
  29. import XMonad.Layout.IM
  30. import XMonad.Layout.ToggleLayouts
  31. import XMonad.Actions.WindowBringer
  32. import Data.Int
  33. import Data.List
  34. import Data.List.Utils (split)
  35. import Data.Ratio
  36. import Data.Maybe
  37. import Data.Monoid
  38. import qualified Data.HashTable as H
  39. import XMonad.Actions.GridSelect
  40. import XMonad.Hooks.ManageDocks
  41. import XMonad.Hooks.DynamicLog
  42. import XMonad.Util.WorkspaceCompare
  43. import XMonad.Layout.Named
  44. import XMonad.Actions.Plane
  45. import XMonad.Layout.LayoutCombinators ((|||))
  46. import XMonad.Actions.CycleSelectedLayouts
  47. import XMonad.Actions.Warp
  48. import XMonad.Actions.Promote
  49. import XMonad.Hooks.UrgencyHook
  50. import XMonad.Util.XUtils (fi)
  51. import XMonad.Util.WindowProperties (getProp32, getProp32s)
  52. import qualified XMonad.Util.ExtensibleState as XS
  53. import Char
  54.  
  55. myWorkspaces = ["q", "w", "e", "a", "s", "d", "y", "x", "c"]
  56.  
  57. myLayout = (desktopLayoutModifiers $ tiledN ||| tiled ||| mtiled ||| tab ||| chat) ||| ffull
  58.   where
  59.      tiledN  = named "tl" $ TallNoMax 1 (3/100) (0.51)
  60.      tiled   = named "TL" $ Tall 1 (3/100) (0.51)
  61.      mtiled  = named "hz" $ Mirror $ Tall 1 (3/100) (0.51)
  62.      tab     = named "tab" $ simpleTabbed
  63.      chat    = named "IM" $ withIM (0.5) (ClassName "Konversation") twotabs
  64.      twotabs = windowNavigation $
  65.                combineTwo (Mirror $ TwoPane 0.03 0.5) simpleTabbed (TwoPane 0.03 0.5)
  66.      ffull   = named "fu" $ noBorders $ Full
  67.  
  68. hashWin :: Window -> Int32
  69. hashWin = H.hashInt . fromIntegral
  70.  
  71. main = withConnection Session $ \ dbus -> do
  72.   getWellKnownName dbus
  73.   pidhash <- H.new (==) H.hashInt
  74.   winhash <- H.new (==) hashWin
  75.   (xmonad
  76.    $ withUrgencyHook NoUrgencyHook
  77.    $ kde4Config {
  78.       modMask = mod4Mask -- use the Windows button as mod
  79.       , manageHook = pidManageHook pidhash winhash <+> manageHook kde4Config <+> myManageHook <+> doF W.shiftMaster
  80.       , handleEventHook = handleEventHook kde4Config <+> attentionEventHook <+> pidEventHook pidhash winhash
  81.       , workspaces = myWorkspaces
  82.       , layoutHook = myLayout
  83.       , logHook = logHook kde4Config >> dynamicLogWithPP (myPrettyPrinter dbus)
  84.       , borderWidth = 2
  85.       }
  86.    `removeKeysP` [ "M-"++n | n <- map show [3..9 :: Int] ]
  87.    `additionalKeys` [((mod4Mask, xK_section), swapNextScreen)]
  88.    `additionalKeysP` myKeys
  89.    `additionalMouseBindings`
  90.    [ ((mod4Mask, button1), (\w -> focus w >> windows W.swapMaster))
  91.    , ((mod4Mask, button2), (\w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster))
  92.    , ((mod4Mask, button3), (\w -> focus w >> mouseResizeWindow w))
  93.    , ((mod4Mask, button4), (\_ -> windows W.focusUp ))
  94.    , ((mod4Mask, button5), (\_ -> windows W.focusDown))
  95.    ])
  96.  where
  97.    myManageHook = composeAll . concat $
  98.      [ [ className   =? c --> doFloat           | c <- myFloats]
  99.      , [ title       =? t --> doFloat           | t <- myOtherFloats]
  100.      , [ className   =? c --> doF (W.shift "w") | c <- mailApps]
  101.      , [ className   =? c --> doF (W.shift "c") | c <- ircApps]
  102.      , [ (fmap ("kmail-composer" `isPrefixOf`) role) --> doF (W.shift "q") ]
  103.      , [ liftX (gets (W.currentTag . windowset)) =? "w" <&&> className =? c --> doShift "e" | c <- webApps ]
  104.      ]
  105.    myFloats      = ["MPlayer", "Gimp", "krunner", "Nvidia-settings", "Plasma-desktop"]
  106.    myOtherFloats = ["alsamixer", "Password – KDE Dæmon"]
  107.    mailApps      = ["Kontact"]
  108.    webApps       = ["Firefox", "Conkeror"] -- open on desktop 3
  109.    ircApps       = ["Konversation", "Skype", "Kopete"] -- open on desktop 9
  110.    role          = stringProperty "WM_WINDOW_ROLE"
  111.  
  112. myKeys = [
  113.    ("M-<Return>", promote)
  114.  , ("M-v", kill)
  115.  , ("M-'", spawn "xmonad --recompile && xmonad --restart")
  116.  , ("M-1", screenWorkspace 0 >>= flip whenJust (windows . W.view))
  117.  , ("M-2", screenWorkspace 1 >>= flip whenJust (windows . W.view))
  118.  , ("M-o", nextScreen)
  119.  , ("M-S-1", screenWorkspace 0 >>= flip whenJust (windows . W.shift))
  120.  , ("M-S-2", screenWorkspace 1 >>= flip whenJust (windows . W.shift))
  121.  , ("M-r M-f", spawn "conkeror")
  122.  , ("M-r M-g", spawn "conkeror")
  123.  , ("M-r M-r", spawn "konsole")
  124.  , ("M-r M-<Space>", spawn "qdbus org.kde.krunner /App org.kde.krunner.App.display")
  125.  , ("M-<Space>", spawn "qdbus org.kde.krunner /App org.kde.krunner.App.display")
  126.  , ("M-r M-d", spawn "digikam")
  127.  , ("M-r M-l", spawn "dolphin")
  128.  , ("M-f M-f", withFocused float )
  129.  , ("M-f M-t", withFocused $ windows . W.sink )
  130.  , ("M-0", refresh)
  131.  , ("M-<U>", sendMessage $ Move U)
  132.  , ("M-<D>", sendMessage $ Move D)
  133.  , ("M-<R>", sendMessage $ Move R)
  134.  , ("M-<L>", sendMessage $ Move L)
  135.  , ("M-n", viewEmptyWorkspace)
  136.  , ("S-M-n", tagToEmptyWorkspace)
  137.  , ("M-g", gotoMenu)
  138.  , ("M-b", bringMenu)
  139.  , ("M-S-b", sendMessage ToggleStruts)
  140.  , ("M-<F1>", cycleThroughLayouts ["tl"])
  141.  , ("M-<F2>", cycleThroughLayouts ["TL"])
  142.  , ("M-<F3>", cycleThroughLayouts ["hz"])
  143.  , ("M-<F4>", cycleThroughLayouts ["tab"])
  144.  , ("M-<F5>", cycleThroughLayouts ["IM"])
  145.  , ("M-<F6>", cycleThroughLayouts ["fu"])
  146.  , ("M-t", warpToWindow (1%2) (1%2))
  147.  , ("M-u", focusUrgent)
  148.  ] ++ [ ("M-" ++ w, windows $ W.greedyView w) | w <- myWorkspaces ]
  149.          ++ [ ("S-M-" ++ w, windows $ W.shift w) | w <- myWorkspaces ]
  150.  
  151. -- | The builtin tiling mode of xmonad. Supports 'Shrink', 'Expand' and
  152. -- 'IncMasterN'.
  153. data TallNoMax a = TallNoMax { tallNMaster :: !Int               -- ^ The default number of windows in the master pane (default: 1)
  154.                    , tallRatioIncrement :: !Rational   -- ^ Percent of screen to increment by when resizing panes (default: 3/100)
  155.                    , tallRatio :: !Rational }          -- ^ Default proportion of screen occupied by master pane (default: 1/2)
  156.                 deriving (Show, Read)
  157.  
  158. -- a nice pure layout, lots of properties for the layout, and its messages, in Properties.hs
  159. instance LayoutClass TallNoMax a where
  160.     pureLayout (TallNoMax nmaster _ frac) r s = zip ws rs
  161.       where ws = W.integrate s
  162.             rs = tileNoMax frac r nmaster (length ws)
  163.  
  164.     pureMessage (TallNoMax nmaster delta frac) m =
  165.             msum [fmap resize     (fromMessage m)
  166.                  ,fmap incmastern (fromMessage m)]
  167.  
  168.       where resize Shrink             = TallNoMax nmaster delta (max 0 $ frac-delta)
  169.             resize Expand             = TallNoMax nmaster delta (min 1 $ frac+delta)
  170.             incmastern (IncMasterN d) = TallNoMax (max 0 (nmaster+d)) delta frac
  171.  
  172.     description _ = "TallNoMax"
  173.  
  174. -- | Compute the positions for windows using the default two-pane tiling
  175. -- algorithm.
  176. --
  177. -- The screen is divided into two panes. All clients are
  178. -- then partioned between these two panes. One pane, the master, by
  179. -- convention has the least number of windows in it.
  180. tileNoMax
  181.     :: Rational  -- ^ @frac@, what proportion of the screen to devote to the master area
  182.     -> Rectangle -- ^ @r@, the rectangle representing the screen
  183.     -> Int       -- ^ @nmaster@, the number of windows in the master pane
  184.     -> Int       -- ^ @n@, the total number of windows to tileNoMax
  185.     -> [Rectangle]
  186. tileNoMax f r nmaster n =
  187.     splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 -- two columns
  188.   where (r1,r2) = splitHorizontallyBy f r
  189.  
  190.  
  191. myPrettyPrinter :: Connection -> PP
  192. myPrettyPrinter dbus = defaultPP {
  193.     ppOutput = outputThroughDBus dbus
  194.   , ppTitle = \x -> x
  195.   , ppCurrent = wrap "[" "]" . bold . pangoSanitize
  196.   , ppVisible = bold
  197.   , ppHidden = pangoSanitize
  198.   , ppHiddenNoWindows = \x -> ""
  199.   , ppUrgent = wrap "" "!" . bold . map toUpper
  200.   , ppOrder = \(ws:layout:_:_) -> [ws,layout]
  201.   , ppSep = " &ndash; "
  202.   , ppSort = mkWsSort getXineramaWsCompare
  203.   }
  204.   where
  205.     bold = wrap "<span style=\"font-weight: bold;\">" "</span>"
  206.  
  207.  
  208. debugPrint :: String -> IO ()
  209. --debugPrint = appendFile "/tmp/xmonad-debug"
  210. debugPrint _ = return ()
  211.  
  212. knownPid :: H.HashTable Int Window -> Int -> IO (Maybe Window)
  213. knownPid pidhash pid = do
  214.   found <- H.lookup pidhash pid
  215.   case found of
  216.     Just w -> do
  217.               debugPrint $ "knownPid true in first case " ++ (show pid) ++ "\n"
  218.               return $ Just w
  219.     _      -> do ppid <- getppid pid
  220.                  debugPrint $ "knownPid ppid is " ++ (show ppid) ++ "\n"
  221.                  if ppid == pid || ppid <= 1
  222.                    then return Nothing
  223.                    else knownPid pidhash ppid
  224.  
  225. getppid :: Int -> IO Int
  226. getppid pid = catch (do stat <- readFile $ "/proc/" ++ (show pid) ++ "/stat"
  227.                         let (_:_:_:ppidstr:_) = split " " stat
  228.                           in return $ read ppidstr)
  229.               (\e -> return 1)
  230.  
  231. hasPid :: H.HashTable Int Window -> Query (Maybe Window)
  232. hasPid pidhash = ask >>= \w -> liftX $ do
  233.   pid <- getProp32s "_NET_WM_PID" w
  234.   io $ debugPrint $ "hasPid " ++ (show pid) ++ "\n"
  235.   case pid of
  236.     Just [p] -> io $ knownPid pidhash (fromIntegral p)
  237.     _ -> return Nothing
  238.  
  239. pidManageHook :: H.HashTable Int Window -> H.HashTable Window Int -> ManageHook
  240. pidManageHook pidhash winhash = do
  241.   interesting <- hasPid pidhash
  242.   case interesting of
  243.     Just parent -> do
  244.          pdesk <- liftX $ gets (W.findTag parent . windowset)
  245.          case pdesk of
  246.            Just d -> do ask >>= \w -> liftX $ flagUrgent w
  247.                         doF $ W.shift d
  248.            _ -> idHook
  249.     _ -> idHook
  250.  
  251. isPidInteresting :: Query Bool
  252. isPidInteresting = className =? "Konsole"
  253.  
  254. updatePid :: H.HashTable Int Window -> H.HashTable Window Int -> Window -> X ()
  255. updatePid pidhash winhash w = do
  256.   pid <- getProp32s "_NET_WM_PID" w
  257.   io $ debugPrint $ "updatePid " ++ (show pid) ++ "\n"
  258.   case pid of
  259.     Just [p] -> do
  260.       _ <- io $ H.update pidhash (fromIntegral p) w
  261.       _ <- io $ H.update winhash w (fromIntegral p)
  262.       return ()
  263.     _        -> return ()
  264.  
  265. removePid :: H.HashTable Int Window -> H.HashTable Window Int -> Window -> X ()
  266. removePid pidhash winhash w = do
  267.   pid <- io $ H.lookup winhash w
  268.   io $ debugPrint $ "removePid " ++ (show pid) ++ "\n"
  269.   case pid of
  270.     Just p -> do
  271.       _ <- io $ H.delete winhash w
  272.       _ <- io $ H.delete pidhash (fromIntegral p)
  273.       return ()
  274.     _        -> return ()
  275.  
  276. pidEventHook :: H.HashTable Int Window -> H.HashTable Window Int -> Event -> X All
  277. pidEventHook pidhash winhash (MapNotifyEvent {ev_window = w}) = do
  278.   whenX (runQuery isPidInteresting w) (updatePid pidhash winhash w)
  279.   return $ All True
  280. pidEventHook pidhash winhash (DestroyWindowEvent {ev_window = w}) = do
  281.   removePid pidhash winhash w
  282.   return $ All True
  283. pidEventHook pidhash winhash _ = return $ All True
  284.  
  285. -- -----------------------------------------------------------------------------
  286.  
  287. -- This retry is really awkward, but sometimes DBus won't let us get our
  288. -- name unless we retry a couple times.
  289. getWellKnownName :: Connection -> IO ()
  290. getWellKnownName dbus = tryGetName `catchDyn` (\ (DBus.Error _ _) ->
  291.                                                 getWellKnownName dbus)
  292.  where
  293.   tryGetName = do
  294.     namereq <- newMethodCall serviceDBus pathDBus interfaceDBus "RequestName"
  295.     addArgs namereq [String "org.xmonad.Log", Word32 5]
  296.     sendWithReplyAndBlock dbus namereq 0
  297.     return ()
  298.  
  299. outputThroughDBus :: Connection -> String -> IO ()
  300. outputThroughDBus dbus str = do
  301.   let str' = "<span style=\"font-size: 12pt\">" ++ str ++ "</span>"
  302.   msg <- newSignal "/org/xmonad/Log" "org.xmonad.Log" "Update"
  303.   addArgs msg [String str']
  304.   send dbus msg 0 `catchDyn` (\ (DBus.Error _ _ ) -> return 0)
  305.   return ()
  306.  
  307. pangoColor :: String -> String -> String
  308. pangoColor fg = wrap left right
  309.  where
  310.   left = "<span foreground=\"" ++ fg ++ "\">"
  311.   right = "</span>"
  312.  
  313. pangoSanitize :: String -> String
  314. pangoSanitize = foldr sanitize ""
  315.  where
  316.   sanitize '>' acc = ">" ++ acc
  317.   sanitize '<' acc = "<" ++ acc
  318.   sanitize '\"' acc = """ ++ acc
  319.   sanitize '&' acc = "&" ++ acc
  320.   sanitize x acc = x:acc
  321.  
  322. flagUrgent :: Window -> X ()
  323. flagUrgent win = adjustUrgents (\ws -> if elem win ws then ws else win : ws)
  324.  
  325. attentionEventHook :: Event -> X All
  326. attentionEventHook (ClientMessageEvent _ _ _ dpy win typ (action:dats)) = do
  327.   state <- getAtom "_NET_WM_STATE"
  328.   attention <- getAtom "_NET_WM_STATE_DEMANDS_ATTENTION"
  329.   wstate <- fromMaybe [] `fmap` getProp32 state win
  330.  
  331.   let isFull = fromIntegral attention `elem` wstate
  332.  
  333.       -- Constants for the _NET_WM_STATE protocol:
  334.       remove = 0
  335.       add = 1
  336.       toggle = 2
  337.       ptype = 4 -- The atom property type for changeProperty
  338.       chWstate f = io $ changeProperty32 dpy win state ptype propModeReplace (f wstate)
  339.  
  340.   when (typ == state && fi attention `elem` dats) $ do
  341.     when (action == add || (action == toggle && not isFull)) $ do
  342.       flagUrgent win
  343.       userCodeDef () =<< asks (logHook . config)
  344.     when (action == remove || (action == toggle && isFull)) $ do
  345.       clearUrgency win
  346.       userCodeDef () =<< asks (logHook . config)
  347.  
  348.   return $ All True
  349.  
  350. attentionEventHook _ = return $ All True
create a new version of this paste RAW Paste Data