Created
May 16, 2013 13:06
-
-
Save trast/5591577 to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {- # OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable | |
| {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards,TypeSynonymInstances, DeriveDataTypeable, ViewPatterns #-} | |
| import System.IO | |
| import Control.Monad | |
| import Control.OldException(catchDyn,try) | |
| import XMonad.Util.Run | |
| import Control.Concurrent | |
| import Control.Arrow (second) | |
| -- import DBus | |
| -- import DBus.Connection | |
| -- import DBus.Message | |
| import System.Cmd | |
| import XMonad hiding ((|||), Connection) | |
| 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.Prompt | |
| import XMonad.Prompt.Window | |
| import XMonad.Layout.MosaicAlt | |
| import qualified Data.Map as M | |
| import Numeric (showHex) | |
| import Data.Bits | |
| import Data.Int | |
| import Data.List | |
| import Data.List.Utils (split) | |
| import Data.Ratio | |
| import Data.Maybe | |
| import Data.Monoid | |
| import Data.String | |
| import Control.Applicative | |
| 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 Data.Char | |
| import XMonad.Layout.Minimize | |
| import XMonad.Layout.Reflect | |
| import XMonad.Hooks.RestoreMinimized | |
| import XMonad.Hooks.ICCCMFocus | |
| import XMonad.Hooks.EwmhDesktops | |
| import XMonad.Hooks.DebugKeyEvents | |
| import XMonad.Util.Run | |
| import XMonad.Prompt.Shell (Shell) | |
| import XMonad.Util.XSelection | |
| import XMonad.Layout.LayoutModifier | |
| import XMonad.Util.Font | |
| import XMonad.Util.Timer | |
| import XMonad.Util.XUtils | |
| import XMonad.Layout.LayoutBuilder | |
| import XMonad.Hooks.SetWMName | |
| myWorkspaces = ["q", "w", "e", "a", "s", "d", "y", "x", "c"] | |
| myLayout = (desktopLayoutModifiers $ tiledN ||| tiled ||| mtiled ||| mosaic ||| tab ||| chat ||| chatmo ||| gimp) ||| ffull | |
| where | |
| tiledN = named "tl" $ reflectHorizPrimary $ TallNoMax 1 (3/100) (0.5) | |
| tiled = named "TL" $ reflectHorizPrimary $ Tall 1 (3/100) (0.5) | |
| mtiled = named "hz" $ Mirror $ Tall 1 (3/100) (0.5) | |
| mosaic = named "as" $ reflectHorizPrimary $ asymLayout | |
| tab = named "tab" $ simpleTabbed | |
| chat = named "IM" $ withIM (0.5) (ClassName "Konversation") twotabs | |
| chatmo = named "IMo" $ reflectHorizPrimary $ reflectHoriz $ withIM (0.4) (ClassName "Konversation") $ MosaicAlt M.empty | |
| -- chat = named "IM" $ withIM (0.5) (ClassName "Konversation") $ Mirror (Tall 1 (3/100) (0.51)) | |
| gimp = named "Gimp" $ withIM (0.1) | |
| (And (Or (ClassName "Gimp") (ClassName "Gimp-2.6")) (Title "Toolbox")) tab | |
| twotabs = configurableNavigation noNavigateBorders $ | |
| combineTwo (Mirror $ TwoPane 0.03 0.5) simpleTabbed (TwoPane 0.03 0.5) | |
| ffull = named "fu" $ noBorders $ Full | |
| asymLayout = layoutN 1 (relBox 0 0 0.67 1) Nothing Full $ | |
| layoutN 1 (relBox 0.67 0 1 0.67) (Just $ relBox 0.67 0 1 1) Full $ | |
| layoutAll (relBox 0.67 0.67 1 1) simpleTabbed | |
| hashWin :: Window -> Int32 | |
| hashWin = H.hashInt . fromIntegral | |
| ----- this bit by vav #xmonad | |
| -- -------------------------------------------------------------- | |
| -- someone smarter and less tired should refactor the whole thing | |
| magicHook :: String -> ManageHook | |
| magicHook cn = isNonModal <&&> className =? cn <&&> (curTag =? "q" <||> curTag =? "c") | |
| -- really should give curTag and nextScreenNotOn the same tag list | |
| <&&> nextScreenNotOn ["q", "c"] --> doShiftNextOr "e" | |
| magicHook' :: String -> ManageHook | |
| magicHook' cn = isNonModal <&&> className =? cn <&&> (curTag =? "q" <||> curTag =? "c") | |
| -- really should give curTag and nextScreenNotOn the same tag list | |
| <&&> not <$> (nextScreenNotOn ["q", "c"]) --> doShift "e" | |
| curTag :: Query WorkspaceId | |
| curTag = liftX (gets $ W.currentTag . windowset) | |
| nextScreenNotOn :: [WorkspaceId] -> Query Bool | |
| nextScreenNotOn tags = not <$> foldl1 (<||>) (map avoidTag tags) | |
| where | |
| avoidTag tag = maybe True (== tag) <$> liftX maybeNextTag | |
| doShiftNextOr :: WorkspaceId -> ManageHook | |
| doShiftNextOr tag = maybe (doShift tag) doShift =<< liftX maybeNextTag | |
| --- key stuff | |
| debugKeyUpDown (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) | |
| = withDisplay $ \dpy -> do | |
| sym <- io $ keycodeToKeysym dpy code 0 | |
| msk <- cleanMask m | |
| nl <- gets numberlockMask | |
| io $ hPutStrLn stderr $ intercalate " " ["key type" | |
| ,show t | |
| ,"code" | |
| ,show code | |
| ,"sym" | |
| ,show sym | |
| ," (" | |
| ,hex sym | |
| ," \"" | |
| ,keysymToString sym | |
| ,"\") mask" | |
| ,hex m | |
| ,"(" ++ vmask nl m ++ ")" | |
| ,"clean" | |
| ,hex msk | |
| ,"(" ++ vmask nl msk ++ ")" | |
| ] | |
| return (All True) | |
| debugKeyUpDown _ = return (All True) | |
| -- | Convenient showHex variant | |
| hex :: (Integral n, Show n) => n -> String | |
| hex v = "0x" ++ showHex v "" | |
| -- | Convert a modifier mask into a useful string | |
| vmask :: KeyMask -> KeyMask -> String | |
| vmask numLockMask msk = intercalate " " $ | |
| reverse $ | |
| fst $ | |
| foldr vmask' ([],msk) masks | |
| where | |
| masks = map (\m -> (m,show m)) [0..toEnum (bitSize msk - 1)] ++ | |
| [(numLockMask,"num" ) | |
| ,( lockMask,"lock" ) | |
| ,(controlMask,"ctrl" ) | |
| ,( shiftMask,"shift") | |
| ,( mod5Mask,"mod5" ) | |
| ,( mod4Mask,"mod4" ) | |
| ,( mod3Mask,"mod3" ) | |
| ,( mod2Mask,"mod2" ) | |
| ,( mod1Mask,"mod1" ) | |
| ] | |
| vmask' _ a@( _,0) = a | |
| vmask' (m,s) (ss,v) | v .&. m == m = (s:ss,v .&. complement m) | |
| vmask' _ r = r | |
| -- -------------------------------------------------------------- | |
| -- | helpers | |
| maybeNextTag :: X (Maybe WorkspaceId) | |
| maybeNextTag = (screenWorkspace =<< screenBy 1) | |
| ----- | |
| main = do --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 | |
| , handleEventHook = handleEventHook kde4Config <+> attentionEventHook <+> pidEventHook pidhash winhash | |
| <+> restoreMinimizedEventHook <+> fullscreenEventHook -- <+> debugKeyUpDown | |
| , workspaces = myWorkspaces | |
| , layoutHook = myLayout | |
| --, logHook = logHook kde4Config >> dynamicLogWithPP (myPrettyPrinter dbus) | |
| , borderWidth = 3 | |
| , startupHook = setWMName "LG3D" | |
| , focusedBorderColor = "darkred" | |
| , normalBorderColor = "gray30" | |
| } | |
| `removeKeysP` [ "M-"++n | n <- map show [3..9 :: Int] ] | |
| `additionalKeys` [ ((mod4Mask, xK_section), swapNextScreen) | |
| , ((mod4Mask .|. shiftMask, xK_section), shiftNextScreen) | |
| --, ((0, xK_Super_L), sendMessage $ DoShowWN) | |
| ] | |
| `additionalKeysP` myKeys | |
| `additionalMouseBindings` | |
| [ ((mod4Mask, button1), (\w -> focus w >> windows W.shiftMaster )) | |
| , ((mod4Mask .|. shiftMask, button1), (\w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster)) | |
| , ((mod4Mask, button2), (\w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster)) | |
| , ((mod4Mask .|. shiftMask, 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)) | |
| , ((mod4Mask .|. shiftMask, button4), (\_ -> sendMessage Expand )) | |
| , ((mod4Mask .|. shiftMask, button5), (\_ -> sendMessage Shrink )) | |
| ]) | |
| where | |
| myManageHook = composeAll . concat $ | |
| [ [ nm <&&> className =? c --> doFloat | c <- myFloats] | |
| , [ nm <&&> title =? t --> doFloat | t <- myOtherFloats] | |
| , [ nm <&&> className =? c --> doF (W.shift "w") | c <- mailApps] | |
| , [ nm <&&> className =? c --> doF (W.shift "c") | c <- ircApps] | |
| , [ nm <&&> className =? c --> doF (W.shift "x") | c <- soundApps] | |
| , [ nm <&&> (fmap ("kmail-composer" `isPrefixOf`) role) --> doF (W.shift "q") ] | |
| , [ magicHook c | c <- webApps ] | |
| , [ magicHook' c | c <- webApps ] | |
| -- , [ nm <&&> liftX (gets (W.currentTag . windowset)) =? "w" <&&> className =? c --> doShift "e" | c <- webApps ] | |
| -- , [ nm --> doF W.shiftMaster ] | |
| ] | |
| myFloats = ["MPlayer", "krunner", "Nvidia-settings", "Plasma-desktop", "Kruler", | |
| "Kmix", "Kded4", "Gimp", "Gimp-2.6", "Wine"] | |
| myOtherFloats = ["alsamixer", "Password – KDE Dæmon"] | |
| mailApps = ["Kontact"] | |
| webApps = ["Firefox", "Conkeror"] -- open on desktop 3 | |
| ircApps = ["Konversation", "Skype", "Kopete"] -- open on desktop 9 | |
| soundApps = ["Amarok", "Pavucontrol"] | |
| role = stringProperty "WM_WINDOW_ROLE" | |
| nm = isNonModal | |
| infixXPConfig = greenXPConfig { | |
| font = "xft:Bitstream Vera Sans Mono:pixelsize=14", | |
| bgColor = "#000030", | |
| fgColor = "#ffffff", | |
| bgHLight = "#0000ff", | |
| fgHLight = "#ffff00", | |
| borderColor = "#000000", | |
| searchPredicate = isInfixOf | |
| } | |
| prefixXPConfig = greenXPConfig { | |
| font = "xft:Bitstream Vera Sans Mono:pixelsize=14", | |
| bgColor = "#000030", | |
| fgColor = "#ffffff", | |
| bgHLight = "#0000ff", | |
| fgHLight = "#ffff00", | |
| borderColor = "#000000", | |
| searchPredicate = isPrefixOf | |
| } | |
| myKeys = [ | |
| ("M-<Return>", promote) | |
| , ("M-v", kill) | |
| , ("M-'", spawn "cd ~/.xmonad && ghc -threaded --make -i -ilib -fforce-recomp xmonad.hs -o xmonad-$(uname -m)-$(uname | tr A-Z a-z) && xmonad --restart") | |
| --, ("M-'", spawn "xmonad --recompile && xmonad --restart") | |
| , ("M-^", rescreen) | |
| , ("M-1", screenWorkspace 0 >>= flip whenJust (windows . W.view)) | |
| , ("M-2", screenWorkspace 1 >>= flip whenJust (windows . W.view)) | |
| , ("M-o", nextScreen) | |
| , ("M-S-o", shiftNextScreen) | |
| , ("M-S-1", screenWorkspace 0 >>= flip whenJust (windows . W.shift)) | |
| , ("M-S-2", screenWorkspace 1 >>= flip whenJust (windows . W.shift)) | |
| , ("M-r M-a", do spawn "conkeror https://elabs.inf.ethz.ch/course/view.php?id=22" | |
| spawn "conkeror https://judge.inf.ethz.ch/jury/submissions.php?cid=25" | |
| return ()) | |
| , ("M-r M-g", spawn "chromium") | |
| , ("M-S-<Return>", spawn "/home/thomas/.local/bin/konsole --new-instance") | |
| , ("M-r M-r", spawn "/home/thomas/.local/bin/konsole --new-instance") | |
| , ("M-r M-<Space>", spawn "qdbus org.kde.krunner /App org.kde.krunner.App.display") | |
| , ("M-<Space>", spawn "/home/thomas/.local/bin/konsole --new-instance") | |
| , ("M-r M-d", spawn "digikam") | |
| , ("M-r M-l", spawn "dolphin") | |
| -- , ("M-r M-e", spawn "emacsclient -c -n") | |
| , ("M-r M-c", spawn "conkeror https://www.google.com/calendar/b/0/render?pli=1") | |
| , ("M-r M-f", spawn "conkeror http://www.google.com/reader/") | |
| , ("M-i", recentDirPrompt infixXPConfig) | |
| , ("M-t M-f", withFocused float ) | |
| , ("M-t M-t", withFocused $ windows . W.sink ) | |
| , ("M-f", windowPromptGoto infixXPConfig { autoComplete = Just 300000 }) | |
| , ("M-b", windowPromptBring infixXPConfig) | |
| , ("M-g", gotoPrompt prefixXPConfig) | |
| , ("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-<F1>", cycleThroughLayouts ["tl", "TL"]) | |
| , ("M-<F2>", cycleThroughLayouts ["as", "hz"]) | |
| , ("M-<F3>", cycleThroughLayouts ["tab"]) | |
| , ("M-<F4>", cycleThroughLayouts ["IM", "IMo", "Gimp"]) | |
| , ("M-<F5>", cycleThroughLayouts ["fu"]) | |
| , ("M-z", warpToWindow 0.51 0.51) | |
| , ("M-u", focusUrgent) | |
| , ("M--", withFocused minimizeWindow) | |
| , ("M-S--", sendMessage RestoreNextMinimizedWin) | |
| , ("M-p M-p", spawn "/home/thomas/.local/bin/setscreens auto") | |
| , ("M-p M-s", spawn "/home/thomas/.local/bin/setscreens first") | |
| , ("M-p M-e", spawn "/home/thomas/.local/bin/setscreens second") | |
| , ("M-p M-b", spawn "/home/thomas/.local/bin/setscreens extend-right") | |
| , ("M-p M-v", spawn "/home/thomas/.local/bin/setscreens extend-above") | |
| , ("M-p M-c", spawn "/home/thomas/.local/bin/setscreens clone") | |
| , ("M-p M-h", spawn "/home/thomas/.local/bin/setscreens auto") | |
| , ("M-m M-e", withFocused (sendMessage . expandWindowAlt)) | |
| , ("M-m M-s", withFocused (sendMessage . shrinkWindowAlt)) | |
| , ("M-m M-t", withFocused (sendMessage . tallWindowAlt)) | |
| , ("M-m M-w", withFocused (sendMessage . wideWindowAlt)) | |
| ] ++ [ ("M-" ++ w, windows $ W.view w) | w <- myWorkspaces ] | |
| ++ [ ("S-M-" ++ w, windows $ W.shift w) | w <- myWorkspaces ] | |
| ++ [ ("C-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) = splitHorizontallyNotTooNarrow f r | |
| splitHorizontallyNotTooNarrow :: RealFrac r => r -> Rectangle -> (Rectangle, Rectangle) | |
| splitHorizontallyNotTooNarrow f (Rectangle sx sy sw sh) = | |
| ( Rectangle sx sy leftw sh | |
| , Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh) | |
| where leftw = max 960 $ floor $ fromIntegral sw * f | |
| -- 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:t:_) -> [ws,layout,t] | |
| -- , ppSep = " | " | |
| -- , ppSort = mkWsSort getXineramaWsCompare | |
| -- } | |
| -- where | |
| -- bold = wrap "<span style=\"font-weight: bold;\">" "</span>" | |
| isNonModal :: Query Bool | |
| isNonModal = ask >>= \w -> liftX $ do | |
| state <- getAtom "_NET_WM_STATE" | |
| modal <- getAtom "_NET_WM_STATE_MODAL" | |
| wstate <- fromMaybe [] `fmap` getProp32 state w | |
| let isModal = fromIntegral modal `elem` wstate | |
| return $ not isModal | |
| 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 = ">" ++ acc | |
| -- sanitize '<' acc = "<" ++ acc | |
| -- sanitize '\"' acc = """ ++ acc | |
| -- sanitize '&' acc = "&" ++ acc | |
| -- sanitize x acc = x:acc | |
| flagUrgent :: Window -> X () | |
| flagUrgent win = adjustUrgents (\ws -> if elem win ws then ws else win : ws) | |
| clearUrgent :: Window -> X () | |
| clearUrgent win = adjustUrgents (\ws -> filter (\w -> win == w) 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 | |
| clearUrgent win | |
| userCodeDef () =<< asks (logHook . config) | |
| return $ All True | |
| attentionEventHook _ = return $ All True | |
| getRecentDirs :: IO [String] | |
| getRecentDirs = fmap lines $ runProcessWithInput "nc" ["-dU", "/home/thomas/.watchsock"] "" | |
| data Dirs = Dirs | |
| instance XPrompt Dirs where | |
| showXPrompt Dirs = "Dir: " | |
| recentDirPrompt :: XPConfig -> X () | |
| recentDirPrompt c = do | |
| cmds <- io getRecentDirs | |
| mkXPrompt Dirs c (mkComplFunFromList' $ map abbrevDir cmds) spawnKonsole | |
| abbrevDir :: String -> String | |
| abbrevDir (stripPrefix "/home/thomas/" -> Just rest) = rest | |
| abbrevDir str = str | |
| expandDir :: String -> String | |
| expandDir ('/':rest) = '/':rest | |
| expandDir short = "/home/thomas/" ++ short | |
| spawnKonsole :: String -> X () | |
| spawnKonsole dir = spawn $ "/home/thomas/.local/bin/konsole --new-instance --workdir " ++ (expandDir dir) | |
| data GotoPrompt = GotoPrompt | |
| instance XPrompt GotoPrompt where | |
| showXPrompt GotoPrompt = "Open: " | |
| appendArg :: String -> String -> String | |
| appendArg arg s = s ++ " " ++ arg | |
| webjumps :: [String] | |
| webjumps = ["google", "wikipedia", "mid"] | |
| gotoPrompt :: XPConfig -> X () | |
| gotoPrompt c = do | |
| sel <- getSelection | |
| let cmds = (map (appendArg sel) webjumps) ++ [sel] in | |
| mkXPrompt GotoPrompt c (mkComplFunFromList' cmds) spawnConkeror | |
| spawnConkeror :: String -> X () | |
| spawnConkeror url = safeSpawn "conkeror" [url] | |
| -- | |
| -- dynamic reflector | |
| -- | |
| data ReflectDir = Horiz | Vert | |
| deriving (Read, Show) | |
| -- | Given an axis of reflection and the enclosing rectangle which | |
| -- contains all the laid out windows, transform a rectangle | |
| -- representing a window into its flipped counterpart. | |
| reflectRect :: ReflectDir -> Rectangle -> Rectangle -> Rectangle | |
| reflectRect Horiz (Rectangle sx _ sw _) (Rectangle rx ry rw rh) = | |
| Rectangle (2*sx + fi sw - rx - fi rw) ry rw rh | |
| reflectRect Vert (Rectangle _ sy _ sh) (Rectangle rx ry rw rh) = | |
| Rectangle rx (2*sy + fi sh - ry - fi rh) rw rh | |
| ysize (Rectangle _ _ _ sh) = sh | |
| data ReflectPrimary a = ReflectPrimary ReflectDir deriving (Show, Read) | |
| instance LayoutModifier ReflectPrimary a where | |
| pureModifier (ReflectPrimary d) r _ wrs = if (ysize r < 1200 && ysize r > 1000) | |
| then (map (second $ reflectRect d r) wrs, Just $ ReflectPrimary d) | |
| else (wrs, Just $ ReflectPrimary d) | |
| modifierDescription (ReflectPrimary d) = "Reflect" ++ xy | |
| where xy = case d of { Horiz -> "X" ; Vert -> "Y" } | |
| reflectHorizPrimary :: l a -> ModifiedLayout ReflectPrimary l a | |
| reflectHorizPrimary = ModifiedLayout (ReflectPrimary Horiz) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment