XMonad window manager config

xmonad.hs

{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, MultiParamTypeClasses, NoMonomorphismRestriction #-}
-- Ty Levad - tylevad@gmail.com
-- xmonad.hs

-- Core Modules
import System.Exit
import XMonad hiding ((|||))
import qualified XMonad.StackSet as W

-- Action Modules
import XMonad.Actions.Commands
import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS
import XMonad.Actions.DynamicWorkspaces
import XMonad.Actions.GridSelect
import XMonad.Actions.Navigation2D
import XMonad.Actions.PerWorkspaceKeys
import XMonad.Actions.RotSlaves
import qualified XMonad.Actions.Search as S
import XMonad.Actions.TagWindows
import XMonad.Actions.Warp
import XMonad.Actions.WindowGo

-- Hook Modules
import XMonad.Hooks.DynamicLog
import XMonad.Hooks.FadeInactive(setOpacity)
import XMonad.Hooks.ManageDocks as M
import XMonad.Hooks.ManageHelpers
import XMonad.Hooks.ServerMode

-- Layout modules
--import XMonad.Layout.Grid
import XMonad.Layout.Accordion
import XMonad.Layout.GridVariants as G
import XMonad.Layout.LayoutCombinators
import XMonad.Layout.LayoutScreens
import XMonad.Layout.MultiToggle
import XMonad.Layout.NoBorders(smartBorders)
import XMonad.Layout.Reflect
import XMonad.Layout.Renamed as R
import XMonad.Layout.ResizableTile
import XMonad.Layout.TwoPane

-- Prompt Modules
import XMonad.Prompt
import XMonad.Prompt.AppendFile
import XMonad.Prompt.Shell

-- Util Modules
import XMonad.Util.EZConfig(additionalKeysP)
import XMonad.Util.NamedScratchpad
import XMonad.Util.Run(spawnPipe, hPutStrLn)
import XMonad.Util.WorkspaceCompare(getSortByTag, getSortByXineramaPhysicalRule)

-- Data module
import Data.List(isInfixOf)

-- Basics
myWS      = ["web","dash","NSP"]
myTerm    = "terminator"
myFont    = "Ubuntu mono:size=10"
myBack    = "#1a1a1a" -- Bar background
myFore    = "#999999" -- Bar foreground
myAcc     = "#25629f" -- Accent color
myHigh    = "#629f25" -- Highlight color
myLow     = "#000000" -- Lowlight color
myVis     = "#9f2562" -- Visible Workspace
myEmpt    = "#555555" -- Empty workspace
myPanel   = "xmobar ~/.xmobarrc_xmonad"
myInfo    = "xmobar"
myTray    = "tray"

-- Main function
main = do
  h <- spawnPipe myPanel
  i <- spawn myTray
  j <- spawn myInfo
  xmonad $ withNavigation2DConfig defaultNavigation2DConfig $ defaultConfig
    { normalBorderColor  = myLow
    , focusedBorderColor = myHigh
    , focusFollowsMouse  = True
    , borderWidth        = 1
    , terminal           = myTerm
    , workspaces         = myWS
    , manageHook         = myHooks
    , logHook            = myLogHook h
    , layoutHook         = smartBorders $
                           avoidStruts  $
                           myLayoutHook
    , handleEventHook    = serverModeEventHook
    } `additionalKeysP` myKeys

-- Log hooks
myLogHook h = (dynamicLogWithPP $ myPP h)

-- Manage hooks
myHooks = myManageHook <+>
          manageDocks  <+>
          namedScratchpadManageHook scratchpads

-- Pretty Printing
myPP h = xmobarPP
  { ppCurrent         = xmobarColor myEmpt "" . wrap "{" "}" . xmobarColor myVis ""
  , ppVisible         = xmobarColor myHigh ""
  , ppHidden          = xmobarColor myFore ""
  , ppHiddenNoWindows = xmobarColor myEmpt ""
  , ppTitle           = xmobarColor myFore "" . shorten 120
  , ppSep             = " "
  , ppWsSep           = " "
  , ppSort            = fmap (namedScratchpadFilterOutWorkspace.) getSortByXineramaPhysicalRule
  , ppOutput          = hPutStrLn h
  , ppLayout          = xmobarColor myAcc "" .
    (\x -> case x of
      "Tile"                 -> "<icon=/home/ty/.xmobar/tile.xbm/>"
      "ReflectX Tile"        -> "<icon=/home/ty/.xmobar/rtile.xbm/>"
      "Mirror Tile"          -> "<icon=/home/ty/.xmobar/mtile.xbm/>"
      "Mirror ReflectX Tile" -> "<icon=/home/ty/.xmobar/mrtile.xbm/>"
      "Full"                 -> "<icon=/home/ty/.xmobar/full.xbm/>"
      "ReflectX Full"        -> "<icon=/home/ty/.xmobar/full.xbm/>"
      "Mirror Full"          -> "<icon=/home/ty/.xmobar/full.xbm/>"
      "Mirror ReflectX Full" -> "<icon=/home/ty/.xmobar/full.xbm/>"
      "Grid"                 -> "<icon=/home/ty/.xmobar/grid.xbm/>"
      "ReflectX Grid"        -> "<icon=/home/ty/.xmobar/grid.xbm/>"
      "Mirror Grid"          -> "<icon=/home/ty/.xmobar/grid.xbm/>"
      "Mirror ReflectX Grid" -> "<icon=/home/ty/.xmobar/grid.xbm/>"
      "Dual"                 -> "<icon=/home/ty/.xmobar/dual.xbm/>"
      "ReflectX Dual"        -> "<icon=/home/ty/.xmobar/dual.xbm/>"
      "Mirror Dual"          -> "<icon=/home/ty/.xmobar/mdual.xbm/>"
      "Mirror ReflectX Dual" -> "<icon=/home/ty/.xmobar/mdual.xbm/>"
      "Fold"                 -> "<icon=/home/ty/.xmobar/fold.xbm/>"
      "ReflectX Fold"        -> "<icon=/home/ty/.xmobar/fold.xbm/>"
      "Mirror Fold"          -> "<icon=/home/ty/.xmobar/mfold.xbm/>"
      "Mirror ReflectX Fold" -> "<icon=/home/ty/.xmobar/mfold.xbm/>"
      _ -> x
    )
  }

-- XPConfig - Prompt fields
myXPConfig = defaultXPConfig
  { font        = "xft:" ++ myFont
  , fgColor     = myFore
  , bgColor     = myBack
  , bgHLight    = myBack
  , fgHLight    = myHigh
  , borderColor = myBack
  , position    = Bottom
  , height      = 16
  , historySize = 0
  }

-- Layout Hook
myLayoutHook = mkToggle (single MIRROR)  $
               mkToggle (single REFLECTX) $
               main
  where
    main = (tall ||| grid ||| dual ||| full ||| fold)
    tall = renamed [R.Replace "Tile"] $
             (ResizableTall 1 (2/100) (11/18) [])
    grid = renamed [R.Replace "Grid"] $
             G.Grid (16/9)
    dual = renamed [R.Replace "Dual"] $
             (TwoPane (2/100) (1/2))
    full = Full
    fold = renamed [R.Replace "Fold"] $ Accordion

-- Layout Transformers
data MyTransformers = MIRROR
  deriving (Read, Show, Eq, Typeable)

instance Transformer MyTransformers Window where
  transform MIRROR x k  = k (Mirror x) (\(Mirror x') -> x')

myManageHook = composeAll
  [ manageHook defaultConfig
  , isFullscreen               --> doFullFloat
  , isDialog                   --> doCenterFloat
  , appName ~? "eog"           --> doFullFloat
  , appName ~? "galculator"    --> doCenterFloat
  , appName ~? "xmessage"      --> doCenterFloat
  , appName ~? "lxappearance"  --> doCenterFloat
  , appName ~? "mplayer"       --> doCenterFloat
  , appName ~? "nitrogen"      --> doCenterFloat
  , appName ~? "squeeze"       --> doCenterFloat
  , appName ~? "vlc"           --> doCenterFloat
  , appName ~? "gsimplecal"    --> doFloat
  , appName ~? "gvim"          --> doTrans 0.9
  , appName ~? "sublime_text"  --> doTrans 0.9
  , appName ~? "xfce4-notifyd" --> doIgnore
  , appName ~? "pavucontrol"   --> smallRect
  ]
  where
    doTrans i = ask >>= \w -> liftX (setOpacity w i) >> idHook

-- Window matching helpers
role = stringProperty "WM_WINDOW_ROLE"
--name = stringProperty "WM_NAME"

-- Additional key bindings
myKeys =
  [("M-S-<Return>", spawn myTerm)
  -- Window Navigation
  ,("M-<Tab>",   windows W.focusDown >> bringMouse)
  ,("M-S-<Tab>", windows W.focusUp >> bringMouse)
  ,("M-j",   bindIn [("Dual",                 rotSlavesDown >> bringMouse)
                    ,("Mirror Dual",          rotSlavesDown >> bringMouse)
                    ,("ReflectX Dual",        rotSlavesDown >> bringMouse)
                    ,("Mirror ReflectX Dual", rotSlavesDown >> bringMouse)
                    ,("",                     windowGo M.D False >> bringMouse)
                    ])
  ,("M-k",   bindIn [("Dual",                 rotSlavesUp >> bringMouse)
                    ,("Mirror Dual",          rotSlavesUp >> bringMouse)
                    ,("ReflectX Dual",        rotSlavesUp >> bringMouse)
                    ,("Mirror ReflectX Dual", rotSlavesUp >> bringMouse)
                    ,("",                     windowGo M.U False >> bringMouse)
                    ])
  ,("M-h",   bindIn [("Full",                 rotAllUp >> bringMouse)
                    ,("Mirror Full",          rotAllUp >> bringMouse)
                    ,("ReflectX Full",        rotAllUp >> bringMouse)
                    ,("Mirror ReflectX Full", rotAllUp >> bringMouse)
                    ,("",                     windowGo M.L False >> bringMouse)
                    ])
  ,("M-l",   bindIn [("Full",                 rotAllDown >> bringMouse)
                    ,("Mirror Full",          rotAllDown >> bringMouse)
                    ,("ReflectX Full",        rotAllDown >> bringMouse)
                    ,("Mirror ReflectX Full", rotAllDown >> bringMouse)
                    ,("",                     windowGo M.R False >> bringMouse)
                    ])
  ,("M4-j",  windowSwap M.D False)
  ,("M4-k",  windowSwap M.U False)
  ,("M4-h",  windowSwap M.L False)
  ,("M4-l",  windowSwap M.R False)
  ,("M-<Return>", windows W.swapMaster >> bringMouse)
  ,("M4-`",  switchLayer >> bringMouse)
  ,("M-z",   withFocused $ windows . W.sink)
  -- Workspace navigation
  ,("M-S-`", cycleWS Next >> bringMouse)
  ,("M-`",   toggleWS' ["NSP"] >> bringMouse)
  ,("M-w",   selectWindow)
  ,("M-S-w", bringWindow)
  ,("M-g",   selectWS)
  ,("M-S-g", takeToWS)
  -- Screen navigation (left and right are handled by synergy)
  ,("M-S-j", screenGo M.D False >> bringMouse)
  ,("M-S-k", screenGo M.U False >> bringMouse)
  -- Dynamic workspaces
  ,("M-S-a", addWorkspacePrompt myXPConfig)
  -- Resize tiles
  ,("M4-S-h", sendMessage Shrink)
  ,("M4-S-l", sendMessage Expand)
  ,("M4-S-j", sendMessage MirrorShrink)
  ,("M4-S-k", sendMessage MirrorExpand)
  -- Window tagging
  ,("M-t",   tagWindow)
  ,("M-S-t", bringTagged)
  -- Layout
  ,("M-<Space>", sendMessage NextLayout)
  ,("M-b", sendMessage ToggleStruts)
  -- Restart/Exit XMonad
  ,("M-q",   spawn "killall xmobar; xmonad --restart")
  ,("M-S-q", spawn "xmonad --recompile; killall xmobar; xmonad --restart")
  ,("M-C-<Delete>", io (exitWith ExitSuccess))
  -- Screenshot!
  ,("<Print>", spawn "scrot '%F-%T_$wx$h.png'")
  -- Volume up
  ,("<XF86AudioRaiseVolume>", spawn "volume +5")
  -- Volume down
  ,("<XF86AudioLowerVolume>", spawn "volume -5")
  -- Volume mute
  ,("<XF86AudioMute>",        spawn "volume")
  ,("<XF86TouchpadToggle>",   spawn "touchpad")
  -- Shell Prompt
  ,("M-p", spawn ("dmenu_run -b -i -fn '" ++ myFont ++ "' -nb '" ++ myBack ++ "' -nf '" ++ myFore ++ "' -sb '" ++ myHigh ++ "'"))
  ,("M-r", shellPrompt myXPConfig)
  ,("M-n", appendFilePrompt myXPConfig ".notes")
  ,("M-m", appendFilePrompt myXPConfig ".work")
  ]
  ++ [("M-d "   ++ k, f) | (k,f) <- utils]
  ++ [("M-f "   ++ k, f) | (k,f) <- audio]
  ++ [("M-a "   ++ k, f) | (k,f) <- style]
  ++ [("M-"     ++ k, f) | (k,f) <- fKeys]
  ++ [("M-s "   ++ k, (bindOn [("fox", firefoxPrompt f), ("", chromiumPrompt f)])) | (k,f) <- query]
  ++ [("M-S-s " ++ k, (bindOn [("fox", firefoxSelect f), ("", chromiumSelect f)])) | (k,f) <- query]
  where
  chromiumPrompt f = S.promptSearchBrowser myXPConfig "chromium" f
  chromiumSelect f = S.selectSearchBrowser "chromium" f
  firefoxPrompt f = S.promptSearchBrowser myXPConfig "firefox" f
  firefoxSelect f = S.selectSearchBrowser "firefox" f
  utils = [("a", spawnApp)
          ,("s", scratchToggle "gvim ~/.notes; gvim --remote-tab-silent ~/.work")
          ,("d", scratchToggle "dashTerm")
          ,("f", scratchToggle "ranger")
          ,("g", scratchToggle "gnotime")
          ,("h", scratchToggle "htop")
          ,("j", scratchToggle "galculator")
          ,("k", scratchToggle "thunar")
          ,("l", scratchToggle "gparted")
          ,(";", scratchToggle "synaptic")
          ,("t", scratchToggle "transmission-gtk")
          ,("w", scratchToggle "toolDB")
          ,("e", scratchToggle "ekg2")
          ,("c", scratchToggle "vimpc")
          ,("p", scratchToggle "google-musicmanager")
          ]
  audio = [("<Space>", spawn "mpc toggle")
          ,("1", spawn "audio_stream 1")
          ,("2", spawn "audio_stream 2")
          ,("3", spawn "audio_stream 3")
          ,("4", spawn "audio_stream 1 2")
          ,("5", spawn "audio_stream 2 3")
          ,("6", spawn "audio_stream 1 3")
          ,("7", spawn "audio_stream 1 2 3")
          ,("r", spawn "mpd --kill; sleep 5 && mpd")
          ,("l", spawn "mpc next")
          ,("h", spawn "mpc prev")
          ,("j", spawn "mpc seek +10")
          ,("k", spawn "mpc seek -10")
          ,("s", spawn "swap_sinks")
          ,("p", unsafePrompt "play_list" myXPConfig)
          ]
  style = [("t", sendMessage $ JumpToLayout "Tile")
          ,("g", sendMessage $ JumpToLayout "Grid")
          ,("d", sendMessage $ JumpToLayout "Dual")
          ,("f", sendMessage $ JumpToLayout "Full")
          ,("a", sendMessage $ JumpToLayout "Fold")
          ,("m", sendMessage $ Toggle MIRROR)
          ,("r", sendMessage $ Toggle REFLECTX)
          ,("s", layoutSplitScreen 2 (TwoPane 0.5 0.5))
          ,("w", rescreen)
          -- Copy Window
          ,("c", windows copyToAll)
          ,("x", killAllOtherCopies)
          ]
  fKeys = [("<F4>",   kill)
          ,("<F5>",   spawn "autoxine")
          ,("<F6>",   spawn "autoxine -1")
          ,("<F10>",  spawn "audio_toggle")
          ,("<F11>",  spawn "pkill -USR1 redshift || redshift -l 39.74:104.98 -t 4200:5200")
          ,("<F12>",  spawn "xcalib -i -a")
          ]
  query = [("g", S.intelligent S.google)
          ,("a", S.searchEngine "Arch"       "http://wiki.archlinux.org/index.php/Special:Search?search=")
          ,("d", S.searchEngine "Dictionary" "http://dictionary.reference.com/browse/")
          ,("e", S.searchEngine "Etymology"  "http://www.etymonline.com/index.php?term=")
          ,("t", S.searchEngine "Thesaurus"  "http://thesaurus.reference.com/browse/")
          ,("w", S.searchEngine "Wikipedia"  "http://en.wikipedia.org/wiki/Special:Search?search=")
          ]

-- Warp
bringMouse = warpToWindow (9/10) (9/10)

-- Scratchpad invocation (for brevity)
scratchToggle a = namedScratchpadAction scratchpads a >> bringMouse

-- Get workspace sort without NSP
getFilterSort = fmap (. filterWS "NSP" ) getSortByTag
filterWS a = filter (\(W.Workspace tag _ _) -> tag /= a)

-- Find and display hidden workspace in given direction using sort
findWS dir t = findWorkspace getFilterSort dir t 1
viewWS dir = windows . W.greedyView =<< findWS dir HiddenNonEmptyWS

-- Remove empty workspaces except static ones declared in myWS
cycleWS dir = removeEmptyWorkspaceAfterExcept myWS (viewWS dir)

-- Named Workspace Navigation
spawnWS ws a = addWorkspace ws >> spawn a

-- Customized bindIn for layout specific key bindings (swiped from XMonad.Actions.PerWorkspaceKeys)
chooseAction' f = gets windowset >>= f . description . W.layout . W.workspace . W.current
bindIn bindings = chooseAction' chooser where
  chooser lo = case lookup lo bindings of
    Just action -> action
    Nothing -> case lookup "" bindings of
      Just action -> action
      Nothing -> return ()

-- Window tagging
bringTagged = withTaggedGlobalP "tagged" shiftHere >> withTaggedGlobal "tagged" (delTag "tagged")
tagWindow   = withFocused (addTag "tagged")

-- GridSelect actions
spawnApp     = runSelectedAction (myGSConfig pink) myApps
selectWindow = goToSelected (myGSConfig blue) >> windows W.swapMaster >> bringMouse
bringWindow  = bringSelected (myGSConfig orange) >> bringMouse
selectWS     = gridselectWorkspace (myGSConfig green) W.greedyView >> bringMouse
takeToWS     = gridselectWorkspace (myGSConfig purple) (\ws -> W.greedyView ws . W.shift ws) >> bringMouse

-- GridSelect config
myGSConfig colorizer = (buildDefaultGSConfig colorizer)
  {gs_cellheight  = 25
  ,gs_cellpadding = 5
  ,gs_cellwidth   = 125
  }

-- Colorizer colors for GridSelect
--aqua   = myColor "#259f62"
blue   = myColor "#25629f"
green  = myColor "#629f25"
orange = myColor "#9f6225"
pink   = myColor "#9f2562"
purple = myColor "#62259f"

-- Colorizer generator
myColor color _ isFg = do
  return $ if isFg
           then (color, myLow)
           else (myLow ,color)

-- ScratchPads
scratchpads =
  [NS "dashTerm" (myTerm ++ " --role=dashTerm") (role ~? "dashTerm") largeRect
  -- Work utility suites
  ,workPad "toolDB" "~/WORK/toolDB" largeRect
  -- Terminal apps
  ,termPad "vimpc"  smallRect
  ,termPad "ekg2"   smallRect
  ,termPad "htop"   smallRect
  ,termPad "ranger" largeRect
  -- GUI apps
  ,xappPad "gvim ~/.notes; gvim --remote-tab-silent ~/.work" "Gvim" largeRect
  ,xappPad "gnotime"          "GnoTime"      doCenterFloat
  ,xappPad "galculator"       "Galculator"   doCenterFloat
  ,xappPad "google-musicmanager" "Google-musicmanager" doCenterFloat
  ,xappPad "thunar"           "Thunar"       largeRect
  ,xappPad "transmission-gtk" "Transmission" largeRect
  ,gksuPad "synaptic"         "Synaptic"     largeRect
  ,gksuPad "gparted"          "Gparted"      largeRect
  ]
    where
      workPad a d = NS a (workTerm a d) (role ~? a)
      workTerm a d = myTerm ++ " -r " ++ a ++ " --working-dir=" ++ d ++ " -l " ++ a  
      termPad a = NS a (consoleApp a) (role ~? a)
      consoleApp a = myTerm ++ " -r " ++ a ++ " --command=\"" ++ a ++ "\""
      --termPad' n a = NS n (consoleApp' n a) (role ~? n)
      --consoleApp' n a = myTerm ++ " -r " ++ n ++ " --command=\"" ++ a ++ "\""
      xappPad a c = NS a a (className ~? c)
      gksuPad a c = NS a ("gksudo " ++ a) (className ~? c)
      role = stringProperty "WM_WINDOW_ROLE"

-- Floating window sizes
largeRect = (customFloating $ W.RationalRect (1/20) (1/20) (9/10) (9/10))
smallRect = (customFloating $ W.RationalRect (1/6) (1/6) (2/3) (2/3))

-- Menus
myApps = [("Sublime Text", (raiseApp' "sublime_text"))
         ,("Firefox",      (raiseApp  "fox" "firefox"))
         ,("Chromium",     (raiseApp  "web" "chromium"))
         ,("Terminal",     (spawn     myTerm))
         ,("GVim",         (raiseApp' "gvim"))
         ,("Steam",        (raiseApp  "steam" "steam"))
         ,("Gimp",         (raiseApp  "gimp" "gimp"))
         ,("Win7",         (raiseApp  "Win7" "virtualbox --startvm Win7 --start-paused"))
         ,("Inkscape",     (raiseApp  "ink" "inkscape"))
         ,("LibreOffice",  (raiseApp  "doc" "libreoffice"))
         ,("Video",        (spawn     "vlc"))
         ,("Themes",       (spawn     "lxappearance"))
         ,("Wallpaper",    (raiseApp' "nitrogen"))
         ]
  where
    raiseApp ws a = (raiseNextMaybe (spawnWS ws a) (appName ~? a)) >> bringMouse
    raiseApp' a = (raiseNextMaybe (spawn a) (appName ~? a)) >> bringMouse
    --raiseClass ws a c = (raiseNextMaybe (spawnWS ws a) (className ~? c)) >> bringMouse
    --raiseClass' a c = (raiseNextMaybe (spawn a) (className ~? c)) >> bringMouse
    --gksuApp ws a = (raiseNextMaybe (spawnWS ws ("gksudo " ++ a)) (appName ~? a)) >> bringMouse
    --myRaiseTerm a d = (raiseNextMaybe (spawnWS a (termApp a d)) (role ~? a)) >> bringMouse
    --termApp a d = myTerm ++ " -r " ++ a ++ " --working-dir=" ++ d ++ " -l " ++ a

-- Query operators
q ~? x = fmap (x `isInfixOf`) q     -- haystack includes needle?
--q !? x = fmap (not . isInfixOf x) q -- haystack excludes needle?
--q ^? x = fmap (x `isPrefixOf`) q    -- haystack has needle head?
--q ?$ x = fmap (x `isSuffixOf`) q    -- haystack has needle tail?