diff options
Diffstat (limited to '')
| -rw-r--r-- | src/Main.hs | 648 | ||||
| -rw-r--r-- | src/XMonad/Actions/FloatSnapSpaced.hs | 108 | ||||
| -rw-r--r-- | src/XMonad/Actions/PerConditionKeys.hs | 23 |
3 files changed, 779 insertions, 0 deletions
diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..edc6af6 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,648 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Main where + +import Control.Monad +import Data.Char +import Data.Function +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Data.Time.Clock +import Data.Time.Format +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import XMonad hiding ((|||)) +import qualified XMonad.Actions.ConstrainedResize as C +import XMonad.Actions.CopyWindow +import XMonad.Actions.CycleWS +import XMonad.Actions.DynamicProjects +import XMonad.Actions.DynamicWorkspaces +import qualified XMonad.Actions.FlexibleManipulate as F +import XMonad.Actions.FloatSnap +import XMonad.Actions.FloatSnapSpaced +import XMonad.Actions.MessageFeedback +import XMonad.Actions.Navigation2D +import XMonad.Actions.PerConditionKeys +import XMonad.Actions.Promote +import XMonad.Actions.SinkAll +import XMonad.Actions.SpawnOn +import XMonad.Actions.Volume +import XMonad.Actions.WithAll +import XMonad.Hooks.CurrentWorkspaceOnTop +import XMonad.Hooks.DynamicLog +import XMonad.Hooks.EwmhDesktops hiding + (fullscreenEventHook) +import XMonad.Hooks.FloatNext +import XMonad.Hooks.ManageDocks +import XMonad.Hooks.ManageHelpers +import XMonad.Hooks.SetWMName +import XMonad.Hooks.UrgencyHook +import XMonad.Layout.Accordion +import XMonad.Layout.BinarySpacePartition +import XMonad.Layout.ComboP +import XMonad.Layout.Decoration +import XMonad.Layout.Fullscreen +import XMonad.Layout.Gaps +import XMonad.Layout.Hidden +import XMonad.Layout.LayoutCombinators +import XMonad.Layout.MultiToggle +import XMonad.Layout.MultiToggle.Instances +import XMonad.Layout.NoBorders +import XMonad.Layout.Reflect +import XMonad.Layout.ResizableTile +import XMonad.Layout.Simplest +import XMonad.Layout.Spacing +import XMonad.Layout.SubLayouts +import XMonad.Layout.Tabbed +import XMonad.Layout.WindowNavigation +import XMonad.Prompt +import XMonad.Prompt.ConfirmPrompt +import XMonad.Prompt.Pass +import XMonad.Prompt.Shell +import XMonad.Prompt.Window +import XMonad.Prompt.Workspace +import qualified XMonad.StackSet as S +import XMonad.Util.Cursor +import XMonad.Util.EZConfig +import XMonad.Util.Loggers +import XMonad.Util.Loggers.NamedScratchpad +import XMonad.Util.NamedActions +import XMonad.Util.NamedScratchpad +import XMonad.Util.NamedWindows +import XMonad.Util.PositionStore +import XMonad.Util.Run +import XMonad.Util.SpawnNamedPipe +import XMonad.Util.WorkspaceCompare +import XMonad.Util.XSelection + +(+++) :: String -> String -> String +(+++) (x:xs) ys = x:xs ++ " " ++ ys +(+++) [] ys = ys + +myBorderWidth :: Dimension +myBorderWidth = 1 + +myBrowser, myNotify, myTerminal :: String -- TODO Pull values with environment variables +myBrowser = "/usr/bin/qutebrowser" +myNotify = "/usr/bin/notify-send" +myTerminal = "/usr/bin/urxvtc" + +showKeybindings :: [((KeyMask, KeySym), NamedAction)] -> NamedAction +showKeybindings a = addName "Show Keybindings" $ io $ do + p <- spawnPipe "/usr/bin/zenity --text-info" -- TOOD Find an application that doesn't rely on any toolkits + hPutStr p $ unlines $ showKm a + hClose p + return () + +data LibnotifyUrgencyHook = LibnotifyUrgencyHook + deriving (Read, Show) + +instance UrgencyHook LibnotifyUrgencyHook where + urgencyHook LibnotifyUrgencyHook w = do + n <- getName w + Just i <- S.findTag w <$> gets windowset + safeSpawn myNotify [show n, "workspace" +++ wrap "[" "]" i] + +main :: IO () +main = xmonad $ ewmh + $ fullscreenSupport + $ docks + $ withUrgencyHook LibnotifyUrgencyHook + $ withNavigation2DConfig myNav2DConf + $ dynamicProjects myProjects + $ addDescrKeys' ((myModMask, xK_F1), showKeybindings) myKeys + myXMonadConfig -- TODO Make selection target the last selected W when changing scopes + +myNav2DConf :: Navigation2DConfig +myNav2DConf = def + { defaultTiledNavigation = hybridNavigation + , floatNavigation = hybridNavigation + , layoutNavigation = [("Full", centerNavigation)] + , unmappedWindowRect = [("Full", singleWindowRect)] + } + +myXMonadConfig = def + { XMonad.borderWidth = myBorderWidth + , XMonad.workspaces = myWorkspaces -- TODO save WS state + , XMonad.layoutHook = myLayoutHook -- TODO save layout state and floating W position + , XMonad.terminal = myTerminal + , XMonad.normalBorderColor = myColorN + , XMonad.focusedBorderColor = myColorF + , XMonad.modMask = myModMask + , XMonad.logHook = myLogHook + , XMonad.startupHook = myStartupHook + , XMonad.mouseBindings = myMouseBindings + , XMonad.manageHook = myManageHook + , XMonad.handleEventHook = myHandleEventHook + , XMonad.focusFollowsMouse = myFocusFollowsMouse + , XMonad.clickJustFocuses = myClickJustFocuses + } + +myFocusFollowsMouse, myClickJustFocuses :: Bool +myFocusFollowsMouse = False +myClickJustFocuses = False + +wsCHAT = "CHA" :: String +wsM1 = "M/1" :: String +wsM2 = "M/2" :: String +wsM3 = "M/3" :: String +wsT = "TER" :: String +wsW1 = "W/1" :: String +wsW2 = "W/2" :: String +wsW3 = "W/3" :: String +wsWWW = "WWW" :: String + +myWorkspaces :: [WorkspaceId] +myWorkspaces = map show [1 .. 9 :: Int] + +myProjects :: [Project] +myProjects = + [ Project { projectName = "Template" + , projectDirectory = "~/" + , projectStartHook = Nothing + } + + , Project { projectName = wsW1 + , projectDirectory = "~/" + , projectStartHook = Just $ do spawnOn wsW1 myTerminal + spawnOn wsW1 myTerminal + } + + , Project { projectName = wsW2 + , projectDirectory = "~/" + , projectStartHook = Just $ do spawnOn wsW2 myTerminal + spawnOn wsW2 myTerminal + } + + , Project { projectName = wsW3 + , projectDirectory = "~/" + , projectStartHook = Just $ do spawnOn wsW3 myTerminal + spawnOn wsW3 myTerminal + } + + , Project { projectName = wsWWW + , projectDirectory = "~/" + , projectStartHook = Just $ spawnOn wsWWW myBrowser + } + ] + +myFont :: String +myFont = "xft:lucy tewi:style=Regular:size=8" -- TODO CJKのフォールバックフォントを追加する + +black1 = "#0b0806" :: String -- TODO get variables from Xresources +black2 = "#2f2b2a" :: String +red1 = "#844d2c" :: String +red2 = "#a64848" :: String +green1 = "#57553a" :: String +green2 = "#897f5a" :: String +yellow1 = "#a17c38" :: String +yellow2 = "#c8b38d" :: String +blue1 = "#41434f" :: String +blue2 = "#526274" :: String +magenta1 = "#6b4444" :: String +magenta2 = "#755c47" :: String +cyan1 = "#59664c" :: String +cyan2 = "#718062" :: String +white1 = "#a19782" :: String +white2 = "#c1ab83" :: String + +myColorN, myColorF :: String +myColorN = black2 +myColorF = white2 + +baseInt, fullInt :: Int +baseInt = 12 +fullInt = baseInt * 2 + +fullDim :: Dimension +fullDim = 12 * 2 + +myTabTheme :: Theme +myTabTheme = def + { activeColor = black1 + , inactiveColor = black2 + , urgentColor = red1 + , activeBorderColor = white1 + , inactiveBorderColor = white2 + , urgentBorderColor = red2 + , activeTextColor = white1 + , inactiveTextColor = white2 + , urgentTextColor = red2 + , fontName = myFont + , decoHeight = fullDim + } + +myPromptTheme, myHotPromptTheme :: XPConfig +myPromptTheme = def + { font = myFont + , bgColor = black1 + , fgColor = white1 + , fgHLight = white2 + , bgHLight = black2 + , borderColor = white2 + , promptBorderWidth = myBorderWidth + , position = Bottom + , height = fullDim + , searchPredicate = isInfixOf `on` map toLower + } +myHotPromptTheme = myPromptTheme + { bgColor = black2 + , fgColor = white2 + , fgHLight = white1 + , bgHLight = black1 + } + +mySpacing :: l a -> ModifiedLayout Spacing l a +mySpacing = spacing baseInt + +myGaps :: l a -> ModifiedLayout Gaps l a +myGaps = gaps [ (U, baseInt) + , (D, baseInt) + , (R, baseInt) + , (L, baseInt) + ] + +data MyTransformers = GAPS + deriving (Read, Show, Eq, Typeable) + +instance Transformer MyTransformers Window where + transform GAPS x k = k (avoidStruts $ myGaps $ mySpacing x) (const x) + +myLayoutHook = fullscreenFloat + $ lessBorders OnlyFloat + $ mkToggle (single NBFULL) + $ avoidStruts + $ mkToggle (single GAPS) + $ mkToggle (single REFLECTX) + $ mkToggle (single REFLECTY) + $ windowNavigation + $ addTabs shrinkText myTabTheme + $ hiddenWindows + $ subLayout [] (Simplest ||| Accordion) -- TODO Proper bindings + emptyBSP + +myModMask :: KeyMask +myModMask = mod4Mask + +myKeys :: XConfig Layout -> [((KeyMask, KeySym), NamedAction)] +myKeys config = let + subKeys :: String -> [(String, NamedAction)] -> [((KeyMask, KeySym), NamedAction)] + subKeys s ks = subtitle s:mkNamedKeymap config ks + + directions :: [Direction2D] + directions = [D, U, L, R] + + arrowKeys, directionKeys, wsKeys :: [String] + arrowKeys = [ "<D>" , "<U>" , "<L>" , "<R>" ] + directionKeys = [ "j" , "k" , "h" , "l" ] + wsKeys = map show [1 .. 9 :: Int] + + zipM :: [a] -> String -> [[a]] -> [t] -> (t -> X ()) -> [([a], NamedAction)] + zipM m nm ks as f = zipWith (\k d -> (m ++ k, addName nm $ f d)) ks as + zipM' :: [a] -> String -> [[a]] -> [t] -> (t -> t1 -> X ()) -> t1 -> [([a], NamedAction)] + zipM' m nm ks as f b = zipWith (\k d -> (m ++ k, addName nm $ f d b)) ks as + + tryMessageR_ :: (Message a, Message b) => a -> b -> X () + tryMessageR_ x y = sequence_ [tryMessage_ x y, refresh] + + unsafeSelectionNotify :: MonadIO m => String -> m () + unsafeSelectionNotify a = join + $ io + $ (unsafeSpawn . (\x -> a +++ "Clipboard" +++ wrap "\"\\\"" "\"\\\"" x)) + <$> getSelection + + toggleCopyToAll :: X () + toggleCopyToAll = wsContainingCopies >>= \x -> case x of + [] -> windows copyToAll + _ -> killAllOtherCopies + + getSortByIndexNonSP :: X ([WindowSpace] -> [WindowSpace]) + getSortByIndexNonSP = (. namedScratchpadFilterOutWorkspace) <$> getSortByIndex + + nextNonEmptyWS, prevNonEmptyWS :: X () + nextNonEmptyWS = findWorkspace getSortByIndexNonSP Next HiddenNonEmptyWS 1 + >>= \t -> windows . S.view $ t + prevNonEmptyWS = findWorkspace getSortByIndexNonSP Prev HiddenNonEmptyWS 1 + >>= \t -> windows . S.view $ t + + toggleFloat :: Window -> X () + toggleFloat w = windows (\s -> if M.member w (S.floating s) + then S.sink w s + else S.float w (S.RationalRect (1/2 - 1/4) (1/2 - 1/4) (1/2) (1/2)) s) + + in + + subKeys "System" + [ ("M-q" , addName "Restart XMonad" $ spawn "/usr/bin/xmonad --restart") + , ("M-C-q" , addName "Recompile & restart XMonad" $ spawn "/usr/bin/xmonad --recompile && /usr/bin/xmonad --restart") + , ("M-S-q" , addName "Quit XMonad" $ confirmPrompt myHotPromptTheme "Quit XMonad?" $ io exitSuccess) + , ("M-x" , addName "Shell prompt" $ shellPrompt myPromptTheme) + , ("M-o" , addName "Goto W prompt" $ windowPrompt myPromptTheme Goto allWindows) + , ("M-S-o" , addName "Bring W prompt" $ windowPrompt myPromptTheme Bring allWindows) + ] + + ^++^ + subKeys "Actions" + [ ("M-C-g" , addName "Cancel" $ return ()) + , ("<XF86ScreenSaver>" , addName "Lock screen" $ spawn "~/.xmonad/bin/\ + \screenlock.sh") + , ("M-S-c" , addName "Print clipboard content" $ unsafeSelectionNotify myNotify) + , ("M-<Print>" , addName "Take a screenshot of the current WS, \ + \upload it and copy link to the buffer" $ spawn "~/.xmonad/bin/\ + \xshot-upload.sh") + , ("M-S-<Print>" , addName "Take a screenshot of the selected area, \ + \upload it and copy link to the buffer" $ spawn "~/.xmonad/bin/\ + \xshot-select-upload.sh") + , ("M-<Insert>" , addName "Start recording screen as webm" $ spawn "~/.xmonad/bin/\ + \xcast.sh --webm") + , ("M-S-<Insert>" , addName "Start recording screen as gif" $ spawn "~/.xmonad/bin/\ + \xcast.sh --gif") + , ("M-C-<Insert>" , addName "Stop recording" $ spawn "/usr/bin/pkill ffmpeg") + , ("M-C-c" , addName "Toggle compton on/off" $ spawn "~/.xmonad/bin/\ + \toggle-compton.sh") + , ("M-C-r" , addName "Toggle redshift on/off" $ spawn "~/.xmonad/bin/\ + \toggle-redshift.sh") + , ("M-C-p" , addName "Toggle touchpad on/off" $ spawn "~/.xmonad/bin/\ + \toggle-touchpad.sh") + , ("M-C-t" , addName "Toggle trackpoint on/off" $ spawn "~/.xmonad/bin/\ + \toggle-trackpoint.sh") + ] + + ^++^ + subKeys "Volume & Music" -- TODO replace play/pause script with Haskell implementation + [ ("<XF86AudioMute>" , addName "ALSA: Mute" $ void toggleMute) + , ("<XF86AudioLowerVolume>" , addName "ALSA: Lower volume" $ void $ lowerVolume 5) + , ("<XF86AudioRaiseVolume>" , addName "ALSA: Raise volume" $ void $ raiseVolume 5) + , ("<XF86AudioPlay>" , addName "MPD: Play/pause" $ spawn "~/.xmonad/bin/mpc-play-pause.sh") + , ("<XF86AudioStop>" , addName "MPD: Stop" $ spawn "/usr/bin/mpc --no-status stop") + , ("<XF86AudioPrev>" , addName "MPD: Previos track" $ spawn "/usr/bin/mpc --no-status prev") + , ("<XF86AudioNext>" , addName "MPD: Next track" $ spawn "/usr/bin/mpc --no-status next") + ] + + ^++^ + subKeys "Spawnables" + [ ("M-<Return>" , addName "Terminal" $ spawn myTerminal) + , ("M-b" , addName "Browser" $ spawn myBrowser) + , ("M-S-p" , addName "Pass prompt" $ passPrompt myPromptTheme) + , ("M-c" , addName "NSP Console" $ namedScratchpadAction myScratchpads "console") + , ("M-m" , addName "NSP Music" $ namedScratchpadAction myScratchpads "music") + , ("M-t" , addName "NSP Top" $ namedScratchpadAction myScratchpads "top") + , ("M-v" , addName "NSP Volume" $ namedScratchpadAction myScratchpads "volume") + ] + + ^++^ + subKeys "Windows" + ( [ ("M-d" , addName "Kill W" kill) + , ("M-S-d" , addName "Kill all W on WS" $ confirmPrompt myHotPromptTheme "Kill all" killAll) + , ("M-C-d" , addName "Duplicate W to all WS" toggleCopyToAll) + , ("M-a" , addName "Hide W" $ withFocused hideWindow) -- FIXME This is so broken + , ("M-S-a" , addName "Restore hidden W" popOldestHiddenWindow) + , ("M-p" , addName "Promote W" promote) + , ("M-s" , addName "Merge W from sublayout" $ withFocused $ sendMessage . MergeAll) + , ("M-S-s" , addName "Unmerge W from sublayout" $ withFocused $ sendMessage . UnMerge) + , ("M-u" , addName "Focus urgent W" focusUrgent) + , ("M-e" , addName "Focus master W" $ windows S.focusMaster) + , ("M-'" , addName "Navigate tabbed W -> D" $ bindOn LD [ ("Tabs" , windows S.focusDown) + , ("" , onGroup S.focusDown') + ]) + , ("M-;" , addName "Navigate tabbed W -> U" $ bindOn LD [ ("Tabs" , windows S.focusUp) + , ("" , onGroup S.focusUp') + ]) + , ("M-S-'" , addName "Swap tabbed W -> D" $ windows S.swapDown) + , ("M-S-;" , addName "Swap tabbed W -> U" $ windows S.swapUp) + ] + + ++ zipM' "M-" "Navigate W" directionKeys directions windowGo True -- TODO W moving + ++ zipM' "M-S-" "Swap W" directionKeys directions windowSwap True + ++ zipM "M-C-" "Merge W with sublayout" directionKeys directions (sendMessage . pullGroup) + + ++ zipM' "M-" "Navigate screen" arrowKeys directions screenGo True + ++ zipM' "M-S-" "Move W to screen" arrowKeys directions windowToScreen True + ++ zipM' "M-C-" "Swap W to screen" arrowKeys directions screenSwap True + ) + + ^++^ + subKeys "Workspaces & Projects" + ( [ ("M-w" , addName "Switch to project" $ switchProjectPrompt myPromptTheme) + , ("M-S-w" , addName "Shift to project" $ shiftToProjectPrompt myPromptTheme) + , ("M-," , addName "Next non-empty WS" nextNonEmptyWS) + , ("M-." , addName "Previous non-empty WS" prevNonEmptyWS) + , ("M-i" , addName "Toggle last WS" $ toggleWS' ["NSP"]) + , ("M-`" , addName "WS prompt" $ workspacePrompt myPromptTheme $ windows . S.shift) + ] + + ++ zipM "M-" "View WS" wsKeys [0 ..] (withNthWorkspace S.greedyView) + ++ zipM "M-S-" "Move W to WS" wsKeys [0 ..] (withNthWorkspace S.shift) + ++ zipM "M-C-S-" "Copy W to WS" wsKeys [0 ..] (withNthWorkspace copy) + ) + + ^++^ + subKeys "Layout Management" + [ ("M-<Tab>" , addName "Cycle layouts" $ sendMessage NextLayout) + , ("M-C-<Tab>" , addName "Cycle sublayouts" $ toSubl NextLayout) + , ("M-S-<Tab>" , addName "Reset layout" $ setLayout $ XMonad.layoutHook config) + , ("M-y" , addName "Toggle float/tile on W" $ withFocused toggleFloat) + , ("M-S-y" , addName "Tile all floating W" sinkAll) + , ("M-S-," , addName "Decrease maximum W count" $ sendMessage $ IncMasterN (-1)) + , ("M-S-." , addName "Increase maximum W count" $ sendMessage $ IncMasterN 1) + , ("M-r" , addName "Rotate/reflect W" $ tryMessageR_ Rotate (Toggle REFLECTX)) + , ("M-S-r" , addName "Reflect W" $ sendMessage $ Toggle REFLECTX) + , ("M-f" , addName "Toggle fullscreen layout" $ sequence_ [ withFocused $ windows . S.sink + , sendMessage $ Toggle NBFULL + ]) + , ("M-S-g" , addName "Toggle gapped layout" $ sendMessage $ Toggle GAPS) -- FIXME Breaks merged tabbed layout + ] + + ^++^ + subKeys "Resize" + [ ("M-[" , addName "Expand L" $ tryMessageR_ (ExpandTowards L) Shrink) + , ("M-]" , addName "Expand R" $ tryMessageR_ (ExpandTowards R) Expand) + , ("M-S-[" , addName "Expand U" $ tryMessageR_ (ExpandTowards U) MirrorShrink) + , ("M-S-]" , addName "Expand D" $ tryMessageR_ (ExpandTowards D) MirrorExpand) + , ("M-C-[" , addName "Shrink L" $ tryMessageR_ (ShrinkFrom R) Shrink) + , ("M-C-]" , addName "Shrink R" $ tryMessageR_ (ShrinkFrom L) Expand) + , ("M-S-C-[" , addName "Shrink U" $ tryMessageR_ (ShrinkFrom D) MirrorShrink) + , ("M-S-C-]" , addName "Shrink D" $ tryMessageR_ (ShrinkFrom U) MirrorExpand) + ] + +myScratchpads :: [NamedScratchpad] +myScratchpads = + [ NS "console" + (spawnTerminalWith "NSPConsole" "~/.xmonad/bin/nsp-console.sh") + (title =? "NSPConsole") + floatingNSP + , NS "volume" + (spawnTerminalWith "NSPVolume" "/usr/bin/alsamixer") + (title =? "NSPVolume") + floatingNSP + , NS "music" + (spawnTerminalWith "NSPMusic" "~/.bin/mp") + (title =? "NSPMusic") + floatingNSP + , NS "top" + (spawnTerminalWith "NSPTop" "/usr/bin/htop") + (title =? "NSPTop") + floatingNSP + ] + where + spawnTerminalWith :: String -> String -> String + spawnTerminalWith t c = myTerminal +++ "-title" +++ t +++ "-e" +++ c + + floatingNSP :: ManageHook + floatingNSP = customFloating $ S.RationalRect x y w h + x = (1 - w) / 2 + y = (1 - h) / 2 + w = 1 / 2 + h = 1 / 2.5 + +xmobarFont :: Int -> String -> String +xmobarFont fn = wrap (concat ["<fn=", show fn, ">"]) "</fn>" + +myTopBarPP :: PP +myTopBarPP = def + { ppCurrent = xmobarColor white2 "" . xmobarFont 2 . wrap "=" "=" + , ppVisible = xmobarColor white1 "" . wrap "~" "~" + , ppHidden = xmobarColor white1 "" . wrap "-" "-" + , ppHiddenNoWindows = xmobarColor white1 "" . wrap "_" "_" + , ppUrgent = xmobarColor red1 "" . wrap "!" "!" + , ppSep = " / " + , ppWsSep = " " + , ppTitle = xmobarColor white1 "" . shorten 50 + , ppTitleSanitize = xmobarStrip + , ppLayout = xmobarColor white1 "" . \x -> case x of + "Spacing 12 Tabbed Hidden BSP" -> "Omni.Gaps" + "Tabbed Hidden BSP" -> "Omni" + _ -> "Misc" + , ppOrder = id + , ppSort = (namedScratchpadFilterOutWorkspace .) <$> getSortByIndex + , ppExtras = [] + } + +myBotBarPP :: PP +myBotBarPP = myTopBarPP + { ppCurrent = const "" + , ppVisible = const "" + , ppHidden = const "" + , ppHiddenNoWindows = const "" + , ppUrgent = const "" + , ppTitle = const "" + , ppLayout = const "" + } + +myLogHook :: X () +myLogHook = do + currentWorkspaceOnTop + ewmhDesktopsLogHook + b1 <- getNamedPipe "xmobarTop" + b2 <- getNamedPipe "xmobarBot" + c <- wsContainingCopies + let copiesCurrent ws | ws `elem` c = xmobarColor yellow2 "" . xmobarFont 2 . wrap "*" "=" $ ws + | otherwise = xmobarColor white2 "" . xmobarFont 2 . wrap "=" "=" $ ws + let copiesHidden ws | ws `elem` c = xmobarColor yellow1 "" . wrap "*" "-" $ ws + | otherwise = xmobarColor white1 "" . wrap "-" "-" $ ws + let copiesUrgent ws | ws `elem` c = xmobarColor yellow2 "" . wrap "*" "!" $ ws + | otherwise = xmobarColor white2 "" . wrap "!" "!" $ ws + dynamicLogWithPP $ myTopBarPP + { ppCurrent = copiesCurrent + , ppHidden = copiesHidden + , ppUrgent = copiesUrgent + , ppOutput = safePrintToPipe b1 + } + dynamicLogWithPP $ myBotBarPP + { ppOutput = safePrintToPipe b2 + } + where + safePrintToPipe :: Maybe Handle -> String -> IO () + safePrintToPipe = maybe (\_ -> return ()) hPutStrLn + +addNETSupported :: Atom -> X () +addNETSupported x = withDisplay $ \d -> do + r <- asks theRoot + ns <- getAtom "_NET_SUPPORTED" + a <- getAtom "ATOM" + liftIO $ do + s <- (join . maybeToList) <$> getWindowProperty32 d ns r + when (fromIntegral x `notElem` s) $ changeProperty32 d r ns a propModeAppend [fromIntegral x] + +addEWMHFullscreen :: X () +addEWMHFullscreen = do + s <- mapM getAtom atoms + mapM_ addNETSupported s + where + atoms :: [String] + atoms = [ "_NET_ACTIVE_WINDOW" + , "_NET_CLIENT_LIST" + , "_NET_CLIENT_LIST_STACKING" + , "_NET_DESKTOP_NAMES" + , "_NET_WM_DESKTOP" + , "_NET_WM_STATE" + , "_NET_WM_STATE_FULLSCREEN" + , "_NET_WM_STATE_HIDDEN" + , "_NET_WM_STRUT" + ] + +myStartupHook :: X () +myStartupHook = do + startupHook def + spawnNamedPipe "/usr/bin/xmobar ~/.xmonad/xmobarrcTop.hs" "xmobarTop" + spawnNamedPipe "/usr/bin/xmobar ~/.xmonad/xmobarrcBot.hs" "xmobarBot" + nspTrackStartup myScratchpads -- TODO + docksStartupHook + addEWMHFullscreen + setDefaultCursor xC_left_ptr + setWMName "xmonad" + +myMouseBindings :: XConfig Layout -> M.Map (KeyMask, Button) (Window -> X ()) -- TODO implement snapSpacedMagicResize +myMouseBindings XConfig {XMonad.modMask = m} = M.fromList + [ ((m, button1), \w -> focus w >> F.mouseWindow F.position w + >> ifClick (snapSpacedMagicMove fullInt (Just 50) (Just 50) w) + >> windows S.shiftMaster + ) + , ((m .|. shiftMask, button1), \w -> focus w >> C.mouseResizeWindow w True + >> ifClick (snapMagicResize [L, R, U, D] (Just 50) (Just 50) w) + >> windows S.shiftMaster + ) + , ((m, button3), \w -> focus w >> F.mouseWindow F.linear w + >> ifClick (snapMagicResize [L, R] (Just 50) (Just 50) w) + >> windows S.shiftMaster + ) + , ((m .|. shiftMask, button3), \w -> focus w >> C.mouseResizeWindow w True + >> ifClick (snapMagicResize [U, D] (Just 50) (Just 50) w) + >> windows S.shiftMaster + ) + ] + +myManageHook :: ManageHook +myManageHook = manageHook def + <+> manageDocks + <+> fullscreenManageHook + <+> namedScratchpadManageHook myScratchpads + <+> composeOne composeActions + where + composeActions :: [MaybeManageHook] + composeActions = [ isFullscreen -?> doFullFloat + , className =? "explorer.exe" -?> doFullFloat + , isDialog -?> doCenterFloat + , className =? "Xmessage" -?> doCenterFloat + , className =? "Zenity" -?> doCenterFloat + , className =? "qemu-system-x86" -?> doCenterFloat + , className =? "qemu-system-x86_64" -?> doCenterFloat + , className =? "Steam" <&&> not <$> title =? "Steam" -?> doFloat + ] + +myHandleEventHook :: Event -> X All +myHandleEventHook = handleEventHook def + <+> nspTrackHook myScratchpads + <+> docksEventHook + <+> fullscreenEventHook + +-- vim:filetype=haskell:expandtab:tabstop=4:shiftwidth=4 diff --git a/src/XMonad/Actions/FloatSnapSpaced.hs b/src/XMonad/Actions/FloatSnapSpaced.hs new file mode 100644 index 0000000..9a66643 --- /dev/null +++ b/src/XMonad/Actions/FloatSnapSpaced.hs @@ -0,0 +1,108 @@ +module XMonad.Actions.FloatSnapSpaced + ( snapSpacedMagicMove + ) where + +import Data.List +import Data.Maybe +import Data.Set (fromList) +import XMonad +import XMonad.Hooks.ManageDocks +import qualified XMonad.StackSet as S + +snapSpacedMagicMove :: Int -> Maybe Int -> Maybe Int -> Window -> X () +snapSpacedMagicMove spacing collidedist snapdist w = whenX (isClient w) $ withDisplay $ \d -> do + io $ raiseWindow d w + wa <- io $ getWindowAttributes d w + + nx <- handleAxis True d wa + ny <- handleAxis False d wa + + io $ moveWindow d w (fromIntegral nx) (fromIntegral ny) + float w + where + handleAxis horiz d wa = do + ((mbl, mbr, bs), (mfl, mfr, fs)) <- getSnap horiz collidedist d w + return $ if bs || fs + then wpos wa + else let b = case (mbl, mbr) of + (Just bl, Just br) -> if wpos wa - bl < br - wpos wa + then bl + spacing + else br + spacing + (Just bl, Nothing) -> bl + spacing + (Nothing, Just br) -> br + spacing + (Nothing, Nothing) -> wpos wa + spacing + + f = case (mfl, mfr) of + (Just fl, Just fr) -> if wpos wa + wdim wa - fl < fr - wpos wa - wdim wa + then fl - spacing + else fr - spacing + (Just fl, Nothing) -> fl - spacing + (Nothing, Just fr) -> fr - spacing + (Nothing, Nothing) -> wpos wa - spacing + + newpos = if abs (b - wpos wa) <= abs (f - wpos wa - wdim wa) + then b + else f - wdim wa + + in if isNothing snapdist || abs (newpos - wpos wa) <= fromJust snapdist + then newpos + else wpos wa + where + (wpos, wdim, _, _) = constructors horiz + +getSnap :: Bool -> Maybe Int -> Display -> Window -> X ((Maybe Int, Maybe Int, Bool), (Maybe Int, Maybe Int, Bool)) +getSnap horiz collidedist d w = do + wa <- io $ getWindowAttributes d w + screen <- S.current <$> gets windowset + let sr = screenRect $ S.screenDetail screen + wl = S.integrate' . S.stack $ S.workspace screen + gr <- fmap ($ sr) $ calcGap $ fromList [minBound .. maxBound] + wla <- filter (collides wa) <$> io (mapM (getWindowAttributes d) $ filter (/= w) wl) + + return ( neighbours (back wa sr gr wla) (wpos wa) + , neighbours (front wa sr gr wla) (wpos wa + wdim wa) + ) + where + wborder = fromIntegral.wa_border_width + + (wpos, wdim, rpos, rdim) = constructors horiz + (refwpos, refwdim, _, _) = constructors $ not horiz + + back wa sr gr wla = dropWhile (< rpos sr) + $ takeWhile (< rpos sr + rdim sr) + $ sort + $ rpos sr : + rpos gr : + (rpos gr + rdim gr) : + foldr (\a as -> wpos a : (wpos a + wdim a + wborder a + wborder wa) : as) [] wla + + front wa sr gr wla = dropWhile (<= rpos sr) + $ takeWhile (<= rpos sr + rdim sr) + $ sort + $ (rpos gr - 2 * wborder wa) : + (rpos gr + rdim gr - 2 * wborder wa) : + (rpos sr + rdim sr - 2 * wborder wa) : + foldr (\a as -> (wpos a - wborder a - wborder wa) : (wpos a + wdim a) : as) [] wla + + neighbours l v = ( listToMaybe $ reverse $ takeWhile (< v) l + , listToMaybe $ dropWhile (<= v) l + , v `elem` l + ) + + collides wa oa = case collidedist of + Nothing -> True + Just dist -> refwpos oa - wborder oa < refwpos wa + refwdim wa + wborder wa + dist + && refwpos wa - wborder wa - dist < refwpos oa + refwdim oa + wborder oa + + +constructors :: Bool -> (WindowAttributes -> Int, WindowAttributes -> Int, Rectangle -> Int, Rectangle -> Int) +constructors True = ( fromIntegral.wa_x + , fromIntegral.wa_width + , fromIntegral.rect_x + , fromIntegral.rect_width + ) +constructors False = ( fromIntegral.wa_y + , fromIntegral.wa_height + , fromIntegral.rect_y + , fromIntegral.rect_height + ) diff --git a/src/XMonad/Actions/PerConditionKeys.hs b/src/XMonad/Actions/PerConditionKeys.hs new file mode 100644 index 0000000..85469d6 --- /dev/null +++ b/src/XMonad/Actions/PerConditionKeys.hs @@ -0,0 +1,23 @@ +module XMonad.Actions.PerConditionKeys + ( XCond(..) + , chooseAction + , bindOn + ) where + +import Data.List +import XMonad +import qualified XMonad.StackSet as S + +data XCond = WS | LD + +chooseAction :: XCond -> (String -> X ()) -> X () +chooseAction WS f = withWindowSet (f . S.currentTag) +chooseAction LD f = withWindowSet (f . description . S.layout . S.workspace . S.current) + +bindOn :: XCond -> [(String, X ())] -> X () +bindOn xc bindings = chooseAction xc chooser + where chooser x = case find ((x ==) . fst) bindings of + Just (_, action) -> action + Nothing -> case find (("" ==) . fst) bindings of + Just (_, action) -> action + Nothing -> return () |