Xmonad/Config archive/adamvo's xmonad.hs

{-# OPTIONS_GHC -Wall -fno-warn-missing-signatures #-}
{-# LANGUAGE NoMonomorphismRestriction, ImplicitParams #-}
module Main where

import XMonad
import qualified XMonad.StackSet as W
import qualified Data.Map as M

-- Update these with:  ghc -ddump-minimal-imports
import Control.Applicative((<*), liftA2)
import Control.Monad(Monad(return, (>>=), (>>)), Functor(..), (=<<), mapM, sequence, zipWithM_)
import Data.List((++), zip, map, concatMap, repeat, zipWith, nub, isPrefixOf, intercalate, isInfixOf)
import Data.Map(fromList)
import Data.Maybe(catMaybes,fromMaybe)
import Graphics.X11.ExtraTypes.XF86(xF86XK_AudioLowerVolume, xF86XK_AudioMute, xF86XK_AudioNext, xF86XK_AudioPlay, xF86XK_AudioPrev, xF86XK_AudioRaiseVolume, xF86XK_AudioStop, xF86XK_Sleep)
import Graphics.X11.Xinerama(getScreenInfo)
import System.IO(IO, Handle, hPutStrLn)

import XMonad.Actions.CycleWS(WSType(NonEmptyWS), WSDirection(..), moveTo)
import XMonad.Actions.DwmPromote(dwmpromote)
import XMonad.Actions.FloatSnap(Direction(..), snapGrow, snapMove, snapShrink)
import XMonad.Actions.GridSelect(defaultGSConfig, goToSelected)
import XMonad.Actions.RandomBackground(randomBg', RandomColor(HSV))
import XMonad.Actions.Search(mathworld, wikipedia, multi, promptSearch)
import XMonad.Actions.SpawnOn(mkSpawner, spawnOn, manageSpawn, shellPromptHere, spawnHere)
import XMonad.Actions.Submap(submap)
import XMonad.Actions.TopicSpace(TopicConfig(..), Topic, (>*>), checkTopicConfig, currentTopicAction, currentTopicDir, pprWindowSet, shiftNthLastFocused, switchNthLastFocused, switchTopic)
import XMonad.Actions.UpdatePointer(PointerPosition(TowardsCentre), updatePointer)
import XMonad.Hooks.DynamicLog(PP(ppUrgent, ppTitle, ppLayout, ppVisible, ppHidden, ppCurrent, ppSep), dynamicLogString, defaultPP, xmobarColor, wrap)
import XMonad.Hooks.EwmhDesktops(ewmhDesktopsEventHook, ewmhDesktopsLogHook)
import XMonad.Hooks.ManageDocks(ToggleStruts(ToggleStruts), avoidStruts, manageDocks)
import XMonad.Hooks.UrgencyHook(FocusHook(..), withUrgencyHook)
import XMonad.Layout.BoringWindows(boringAuto, focusDown, focusUp)
import XMonad.Layout.LayoutHints(layoutHintsToCenter)
import XMonad.Layout.Mosaic(Aspect(Wider, Taller), mosaic)
import XMonad.Layout.Named(named)
import XMonad.Layout.NoBorders(Ambiguity(Screen), lessBorders, noBorders)
import XMonad.Layout.Simplest(Simplest(..))
import XMonad.Layout.SubLayouts
import XMonad.Layout.Tabbed(defaultTheme, addTabs, shrinkText)
import XMonad.Layout.WindowNavigation(Navigate(Swap, Go), configurableNavigation, navigateColor)
import XMonad.Prompt(XPConfig(font), XPrompt(showXPrompt), greenXPConfig, mkXPrompt)
import XMonad.Prompt.RunOrRaise(runOrRaisePrompt)
import XMonad.Prompt.Ssh(sshPrompt)
import XMonad.Prompt.Window(windowPromptGoto)
import XMonad.Prompt.Workspace(workspacePrompt)
import XMonad.Prompt.XMonad(xmonadPrompt)
import XMonad.Util.EZConfig(additionalKeys)
import XMonad.Util.Run(spawnPipe)
import XMonad.Util.StringProp(setStringProp,getStringProp)

main :: IO ()
main = do
    spawner <- mkSpawner
    let ?spawner = spawner
    checkTopicConfig myTopics myTopicConfig
    xmonad . withUrgencyHook FocusHook . myConfig =<< mapM xmobarScreen =<< getScreens

myConfig hs = let c = defaultConfig {
      layoutHook = myLayout
    , focusedBorderColor = "#ff0000"
    , terminal = "urxvt"
    , modMask = mod4Mask
    , logHook = do
        ewmhDesktopsLogHook
        multiPP'
            (mergePPOutputs [pprWindowSet myTopicConfig,dynamicLogString . onlyTitle])
            myPP
            myPP { ppTitle = const "" }
            hs
        updatePointer (TowardsCentre 0.2 0.2)
    , handleEventHook = ewmhDesktopsEventHook
    , workspaces = myTopics
    , manageHook = fmap ("Gran Paradiso" `isInfixOf`) className --> doShift "web" <+> manageSpawn ?spawner <+> manageDocks
    } in additionalKeys c (myKeys c)

myXPConfig :: XPConfig
myXPConfig = greenXPConfig { font = "xft:Profont:pixelsize=15:autohint=true" }

-------------------- Layout ----------------------------------
myLayout = avoidStruts $ named "M" m ||| named "F" (noBorders Full)
    where m = lessBorders Screen
            $ addTabs shrinkText defaultTheme
            $ configurableNavigation (navigateColor "#ffff00")
            $ boringAuto
            $ subLayout [] Simplest
            $ layoutHintsToCenter
            $ mosaic 1.5 [5,4,2] -- manual 0.2
--------------------------------------------------------------

-------------------- Keys ------------------------------------
myKeys c@(XConfig { modMask = modm }) =
    [ ((modm,               xK_Left),  withFocused $ snapMove L Nothing)
    , ((modm,               xK_Right), withFocused $ snapMove R Nothing)
    , ((modm,               xK_Up),    withFocused $ snapMove U Nothing)
    , ((modm,               xK_Down),  withFocused $ snapMove D Nothing)
    , ((modm .|. shiftMask, xK_Left),  withFocused $ snapShrink R Nothing)
    , ((modm .|. shiftMask, xK_Right), withFocused $ snapGrow R Nothing)
    , ((modm .|. shiftMask, xK_Up),    withFocused $ snapShrink D Nothing)
    , ((modm .|. shiftMask, xK_Down),  withFocused $ snapGrow D Nothing)

    ,((modm .|. controlMask, xK_o), withFocused $ sendMessage . UnMerge)
    ,((modm .|. shiftMask .|. controlMask, xK_o), withFocused $ sendMessage . UnMergeAll)
    ,((modm .|. controlMask, xK_m), withFocused $ sendMessage . MergeAll)
    ,((modm .|. controlMask, xK_period), onGroup W.focusDown')
    ,((modm .|. controlMask, xK_comma), onGroup W.focusUp')

    ,((modm, xK_semicolon), sendMessage Taller)
    ,((modm, xK_o), sendMessage Wider)

    ,((modm, xK_x), submap $ M.fromList subMaps)
    ,((modm, xK_s), submap $ fmap (>> refresh) $ defaultSublMap c)

    ,((modm, xK_period), moveTo Next NonEmptyWS)
    ,((modm, xK_comma ), moveTo Prev NonEmptyWS)
    ,((modm .|. shiftMask, xK_period), focusDown)
    ,((modm .|. shiftMask, xK_comma ), focusUp)

    ,((modm .|. shiftMask, xK_a), currentTopicAction myTopicConfig)
    ,((modm, xK_a), goToSelected defaultGSConfig)
    ,((modm, xK_Tab), switchNthLastFocused myTopicConfig 1)
    ,((modm, xK_g), promptedGoto)
    ,((modm .|. shiftMask, xK_g), promptedShift)

    ,((modm, xK_Return), dwmpromote)
    ,((modm .|. shiftMask, xK_Return), spawnShell)
    ,((modm, xK_q), spawn "~/.xmonad/xmonad-recomp.lhs && xmonad --restart")
    ,((modm .|. shiftMask, xK_q), spawn "~/wip/x11-wm/xmonad/rebuild.sh")
    ,((0, xK_Print),  spawn "scrot")

    ]
    ++
    concatMap (\(m,f) -> lrud (modm .|. m) f)
        [(shiftMask, sendMessage . Swap)
        ,(controlMask,  sendMessage . pullGroup)
        ,(controlMask .|. shiftMask, sendMessage . pushWindow)
        ,(0, (sendMessage . Go))
        ]
    ++ mediaKeys ++
    [((m .|. modm, key), screenWorkspace sc >>= flip whenJust (windows . f)) |
        (f, m) <- [(W.view, 0), (W.shift, shiftMask)],
        (key, sc) <- zip [xK_w, xK_f, xK_p] ([0 .. ])]
    ++
    [ ((modm .|. m, k), a i)
        | (a, m) <- [(switchNthLastFocused myTopicConfig,0),(shiftNthLastFocused, shiftMask)]
        , (i, k) <- zip [1..] [xK_1 .. xK_9]]

-- helper for windowNavigation keys
--    note: with colemak neiu are placed where jkli are with qwerty layout
lrud :: a -> (Direction -> b) -> [((a, KeySym), b)]
lrud m cmd = zip ks cmds
    where
      ks = zip (repeat m) [xK_n,xK_i,xK_u,xK_e]
      cmds = zipWith ($) (repeat cmd) [L,R,U,D]

subMaps = [((0, xK_o),  runOrRaisePrompt myXPConfig),
           ((0, xK_p),  shellPromptHere ?spawner myXPConfig),
           ((0, xK_x), xmonadPrompt myXPConfig),
           ((0, xK_z), sshPrompt myXPConfig),
           ((shiftMask, xK_w), windowPromptGoto myXPConfig),
           ((0, xK_w), promptSearch myXPConfig wikipedia),
           ((0, xK_s), promptSearch myXPConfig multi),
           ((0, xK_m), promptSearch myXPConfig mathworld),
           ((0, xK_b), sendMessage ToggleStruts),
           ((0, xK_f), withFocused $ windows . W.sink),
           ((0, xK_v), refresh),
           ((0, xK_c), asks config >>= spawnHere ?spawner . terminal),
           ((0, xK_k), kill)
           ]

mediaKeys = [((0, xF86XK_AudioPlay), mpcAct "toggle"),
             ((0, xF86XK_AudioStop), hostPrompt),
             ((0, xF86XK_AudioNext), mpcAct "next"),
             ((0, xF86XK_AudioPrev), mpcAct "prev"),
             ((0, xF86XK_AudioMute),  spawn "ossmix vmix0-outvol 0"),
             ((shiftMask, xF86XK_AudioMute),  spawn "~/bin/speakers.sh"),
             ((0, xF86XK_AudioLowerVolume),         spawn "ossmix vmix0-outvol -- -1"),
             ((shiftMask, xF86XK_AudioLowerVolume), spawn "ossmix vmix0-outvol -- -0.1"),
             ((0, xF86XK_AudioRaiseVolume),         spawn "ossmix vmix0-outvol +1"),
             ((shiftMask, xF86XK_AudioRaiseVolume), spawn "ossmix vmix0-outvol +0.1"),
             ((0, xF86XK_Sleep), spawn "sudo sh -c 'echo mem > /sys/power/state'")]
    where mpcAct c = do
            h <- withDisplay $ flip getStringProp mpdHost
            spawn $ unwords ["export MPD_HOST="++fromMaybe "localhost" h,";","mpc",c]

mpdHost = "XMONAD_MPD_HOST"

-- Prompt for host
data HostPrompt = HostPrompt
instance XPrompt HostPrompt where showXPrompt _ = "Pick MPD Host: "
hostPrompt = mkXPrompt HostPrompt myXPConfig (return . compl) f
    where compl s = nub $ filter (s `isPrefixOf`) ["localhost","dell"]
          f x = withDisplay $ \d -> setStringProp d mpdHost x
--------------------------------------------------------------

-------------------- Support for per-screen xmobars ---------
-- Some parts of this should be merged into contrib sometime
getScreens :: IO [Int]
getScreens = openDisplay "" >>= liftA2 (<*) f closeDisplay
    where f = fmap (zipWith const [0..]) . getScreenInfo

-- | Output to each handle what would be seen when viewing the screen with that
-- index. If the workspace is focused use the first PP, otherwise use the
-- second PP.
multiPP :: PP -> PP -> [Handle] -> X ()
multiPP = multiPP' dynamicLogString

multiPP' :: (PP -> X String) -> PP -> PP -> [Handle] -> X ()
multiPP' dynlStr focusPP unfocusPP handles = do
    state <- get
    let viewWs n = put state { windowset = W.view n $ windowset state }
        focused = W.tag . W.workspace . W.current $ windowset state
        choosePP w = if w == focused then focusPP else unfocusPP
    io . zipWithM_ hPutStrLn handles
            =<< mapM (\w -> viewWs w >> dynlStr (choosePP w)) . catMaybes
            =<< mapM screenWorkspace (zipWith const [0..] handles)
    put state

mergePPOutputs :: [PP -> X String] -> PP -> X String
mergePPOutputs x pp = fmap (intercalate (ppSep pp)) . sequence $ map ($ pp) x

onlyTitle :: PP -> PP
onlyTitle pp = defaultPP { ppCurrent = const "", ppHidden = const "", ppVisible = const "", ppLayout = ppLayout pp, ppTitle = ppTitle pp }

-- | Requires a recent addition to xmobar (>0.9.2)
xmobarScreen :: Int -> IO Handle
xmobarScreen = spawnPipe . ("xmobar -x " ++) . show

myPP :: PP
myPP = defaultPP
    { ppTitle = xmobarColor "orange" ""
    , ppCurrent = xmobarColor "white" ""
    , ppSep = " : "
    , ppLayout = xmobarColor "green" ""
    , ppVisible = xmobarColor "white" "" . wrap "(" ")"
    , ppUrgent = xmobarColor "red" "" . ("^"++)}
--------------------------------------------------------------

-------------------- X.Actions.TopicSpace --------------------
myTopics :: [Topic]
myTopics =
  [ "dashboard" -- the first one
  , "admin", "build", "cleaning", "conf", "darcs", "haskell", "irc"
  , "mail", "movie", "music", "talk", "text", "web"
  , "yi", "documents", "pdf", "xmobar", "xmonad-conf", "xmonad-extras", "xmonad-newconfig", "xmonad-contrib"
  , "gitit", "gimp"
  ]

myTopicConfig = TopicConfig
  { topicDirs = M.fromList $
      [ ("conf", "conf")
      , ("dashboard", "./")
      , ("yi", "wip/dev-haskell/yi")
      , ("darcs", "wip/dev-haskell/darcs")
      , ("haskell", "haskell")
      , ("xmonad-conf", ".xmonad")
      , ("xmonad-extras", "wip/x11-wm/xmonad/extras/xmonad-extras/XMonad")
      , ("xmonad-newconfig", "wip/x11-wm/xmonad/core/xmonad-newconfig")
      , ("xmonad-contrib", "wip/x11-wm/xmonad/contrib/XMonadContrib/XMonad")
      , ("xmobar", "wip/x11-wm/xmobar")
      , ("movie", "media/movie")
      , ("music", "media/music")
      , ("documents", "doc")
      , ("pdf", "ref")
      , ("gitit", "wip/gitit")
      , ("gimp", "./")
      ]
  , defaultTopicAction = const $ spawnShell >*> 2
  , defaultTopic = "dashboard"
  , maxTopicHistory = 10
  , topicActions = M.fromList $
      [ ("xmonad-conf", spawnShellIn ".xmonad/lib/XMonad/Layout" >>
                        spawn "urxvt -e vim ~/.xmonad/xmonad.hs")
      , ("xmonad-contrib", spawnShell >*> 2)
      , ("xmonad-newconfig", spawn "urxvt -e vim ~/wip/x11-wm/xmonad/core/xmonad-newconfig/XMonad/ConfigMonad.hs")
      , ("xmobar",     spawnShellIn "wip/x11-wm/xmobar/Plugins" >*> 2)
      , ("music",      spawn "urxvt -e ncmpc" >> spawn "export MPD_HOST=192.168.1.2; mpc && urxvt -e ncmpc -h 192.168.1.2")
      , ("mail",       spawn "urxvt -e mutt")
      , ("irc",        spawn "urxvt -e ssh engage.uwaterloo.ca")
      , ("dashboard",  spawnShell)
      , ("web",        spawn "firefox")
      , ("movie",      spawnShell)
      , ("pdf",        spawn "okular")
      , ("gimp",       spawnOn ?spawner "gimp" "gimp")
      ]
  }

-- From the sample config in TopicSpace, these should probably be exported from that module
spawnShell = currentTopicDir myTopicConfig >>= spawnShellIn

spawnShellIn dir = do
    color <- randomBg' (HSV 15 0)
    t <- asks (terminal . config)
    spawnHere ?spawner $ "cd " ++ dir ++ " && " ++ t ++ " -bg " ++ color

promptedGoto = workspacePrompt myXPConfig $ switchTopic myTopicConfig

promptedShift = workspacePrompt myXPConfig $ \x -> windows (W.greedyView x . W.shift x)