XMonad.Config.Dmwit

Ignore-this: 7402161579fd2e191b60a057d955e5ea

darcs-hash:20130502012132-76d51-db5a8296f28a2d9e16e5961bf8a235c8a0d078ed.gz

1 files changed, 324 insertions, 0 deletions

diff --git a/XMonad/Config/Dmwit.hs b/XMonad/Config/Dmwit.hs
new file mode 100644
index 0000000..f899b59
--- /dev/null
+++ b/XMonad/Config/Dmwit.hs
@@ -0,0 +1,324 @@
+-- boilerplate {{{
+{-# LANGUAGE ExistentialQuantification, NoMonomorphismRestriction, TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults #-}
+module XMonad.Config.Dmwit where
+
+-- system imports
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans
+import Data.Char
+import Data.List
+import Data.Map (Map, fromList)
+import Data.Ratio
+import Data.Word
+import GHC.Real
+import System.Environment
+import System.Exit
+import System.IO
+import System.Process
+
+-- xmonad core
+import XMonad
+import XMonad.StackSet hiding (workspaces)
+
+-- xmonad contrib
+import XMonad.Actions.SpawnOn
+import XMonad.Actions.Warp
+import XMonad.Hooks.DynamicLog
+import XMonad.Hooks.ManageDocks
+import XMonad.Hooks.ManageHelpers
+import XMonad.Hooks.SetWMName
+import XMonad.Layout.Grid
+import XMonad.Layout.IndependentScreens
+import XMonad.Layout.Magnifier
+import XMonad.Layout.NoBorders
+import XMonad.Util.Dzen hiding (x, y)
+import XMonad.Util.SpawnOnce
+-- }}}
+-- volume {{{
+outputOf :: String -> IO String
+outputOf s = do
+    uninstallSignalHandlers
+    (hIn, hOut, hErr, p) <- runInteractiveCommand s
+    mapM_ hClose [hIn, hErr]
+    hGetContents hOut <* waitForProcess p <* installSignalHandlers
+
+geomMean :: Floating a => [a] -> a
+geomMean xs = product xs ** (recip . fromIntegral . length $ xs)
+
+arithMean :: Floating a => [a] -> a
+arithMean xs = sum xs / fromIntegral (length xs)
+
+namedNumbers n s = do
+    l <- lines s
+    guard (sentinel `isPrefixOf` l)
+    return (drop (length sentinel) l)
+    where sentinel = n ++ " #"
+
+-- Data.List.Split.splitOn ":", but without involving an extra dependency
+splitColon xs = case break (==':') xs of
+    (a, ':':b) -> a : splitColon b
+    (a, _)     -> [a]
+
+parse s = arithMean $ do
+    l <- lines s
+    guard ("\tVolume: " `isPrefixOf` l)
+    part <- splitColon l
+    (n,'%':_) <- reads part
+    return n
+
+modVolume :: String -> Integer -> IO Double
+modVolume kind n = do
+    is <- namedNumbers parseKind <$> outputOf listCommand
+    forM_ is (outputOf . setCommand)
+    parse <$> outputOf listCommand
+    where
+    sign | n > 0 = "+" | otherwise = "-"
+    ctlKind      = map (\c -> if c == ' ' then '-' else c) kind
+    parseKind    = unwords . map (\(c:cs) -> toUpper c : cs) . words $ kind
+    setCommand i = "pactl set-" ++ ctlKind ++ "-volume " ++ i ++ " -- " ++ sign ++ show (abs n) ++ "%"
+    listCommand  = "pactl list " ++ ctlKind ++ "s"
+-- }}}
+-- convenient actions {{{
+centerMouse = warpToWindow (1/2) (1/2)
+statusBarMouse = warpToScreen 0 (5/1600) (5/1200)
+withScreen s f = screenWorkspace s >>= flip whenJust (windows . f)
+
+makeLauncher yargs run exec close = concat
+    ["exe=`yeganesh ", yargs, "` && ", run, " ", exec, "$exe", close]
+launcher     = makeLauncher "" "eval" "\"exec " "\""
+termLauncher = makeLauncher "-p withterm" "exec urxvt -e" "" ""
+viewShift  i = view i . shift i
+floatAll     = composeAll . map (\s -> className =? s --> doFloat)
+sinkFocus    = peek >>= maybe id sink
+showMod  k n = liftIO (modVolume k n) >>= volumeDzen . show . round
+volumeDzen   = dzenConfig $ onCurr (center 170 66) >=> font "-*-helvetica-*-r-*-*-64-*-*-*-*-*-*-*,-*-terminus-*-*-*-*-64-*-*-*-*-*-*-*"
+-- }}}
+altMask = mod1Mask
+bright  = "#80c0ff"
+dark    = "#13294e"
+-- manage hooks for mplayer {{{
+fullscreen43on169 = expand $ RationalRect 0 (-1/6) 1 (4/3) where
+    expand (RationalRect x y w h) = RationalRect (x - bwx) (y - bwy) (w + 2 * bwx) (h + 2 * bwy)
+    bwx = 2 / 1920 -- borderwidth
+    bwy = 2 / 1080
+
+fullscreenMPlayer = className =? "MPlayer" --> do
+    dpy   <- liftX $ asks display
+    win   <- ask
+    hints <- liftIO $ getWMNormalHints dpy win
+    case fmap (approx . fst) (sh_aspect hints) of
+        Just ( 4 :% 3)  -> viewFullOn 0 "5" win
+        Just (16 :% 9)  -> viewFullOn 1 "5" win
+        _               -> doFloat
+    where
+    fi               = fromIntegral :: Dimension -> Double
+    approx (n, d)    = approxRational (fi n / fi d) (1/100)
+
+operationOn f s n w = do
+    let ws = marshall s n
+    currws <- liftX $ screenWorkspace s
+    doF $ view ws . maybe id view currws . shiftWin ws w . f w
+
+viewFullOn = operationOn sink
+centerWineOn = operationOn (`XMonad.StackSet.float` RationalRect (79/960) (-1/540) (401/480) (271/270))
+-- }}}
+-- debugging {{{
+class Show a => PPrint a where
+    pprint :: Int -> a -> String
+    pprint _ = show
+
+data PPrintable = forall a. PPrint a => P a
+instance Show   PPrintable where show     (P x) = show x
+instance PPrint PPrintable where pprint n (P x) = pprint n x
+
+record :: String -> Int -> [(String, PPrintable)] -> String
+record s n xs = preamble ++ intercalate newline fields ++ postlude where
+    indentation = '\n' : replicate n '\t'
+    preamble    = s ++ " {" ++ indentation
+    postlude    = indentation ++ "}"
+    newline     = ',' : indentation
+    fields      = map (\(name, value) -> name ++ " = " ++ pprint (n+1) value) xs
+
+instance PPrint a => PPrint (Maybe a) where
+    pprint n (Just x) = "Just (" ++ pprint n x ++ ")"
+    pprint _ x        = show x
+
+instance PPrint a => PPrint [a] where
+    pprint _ [] = "[]"
+    pprint n xs = preamble ++ intercalate newline allLines ++ postlude where
+        indentation = '\n' : replicate n '\t'
+        preamble    = "[" ++ indentation
+        allLines    = map (pprint (n+1)) xs
+        newline     = ',' : indentation
+        postlude    = indentation ++ "]"
+
+instance PPrint Rectangle where
+    pprint n x = record "Rectangle" n [
+        ("rect_x", P (rect_x x)),
+        ("rect_y", P (rect_y x)),
+        ("rect_width", P (rect_width x)),
+        ("rect_height", P (rect_height x))
+        ]
+
+instance PPrint a => PPrint (Stack a) where
+    pprint n x = record "Stack" n [
+        ("focus", P (XMonad.StackSet.focus x)),
+        ("up", P (up x)),
+        ("down", P (down x))
+        ]
+
+instance (PPrint i, PPrint l, PPrint a) => PPrint (Workspace i l a) where
+    pprint n x = record "Workspace" n [
+        ("tag", P (tag x)),
+        ("layout", P (layout x)),
+        ("stack", P (stack x))
+        ]
+
+instance PPrint ScreenDetail where
+    pprint n x = record "SD" n [("screenRect", P (screenRect x))]
+
+instance (PPrint i, PPrint l, PPrint a, PPrint sid, PPrint sd) => PPrint (XMonad.StackSet.Screen i l a sid sd) where
+    pprint n x = record "Screen" n [
+        ("workspace", P (workspace x)),
+        ("screen", P (screen x)),
+        ("screenDetail", P (screenDetail x))
+        ]
+
+instance (PPrint i, PPrint l, PPrint a, PPrint sid, PPrint sd) => PPrint (StackSet i l a sid sd) where
+    pprint n x = record "StackSet" n [
+        ("current", P (current x)),
+        ("visible", P (visible x)),
+        ("hidden", P (hidden x)),
+        ("floating", P (floating x))
+        ]
+
+instance PPrint (Layout a)
+instance PPrint Int
+instance PPrint XMonad.Screen
+instance PPrint Integer
+instance PPrint Position
+instance PPrint Dimension
+instance PPrint Char
+instance PPrint Word64
+instance PPrint ScreenId
+instance (Show a, Show b) => PPrint (Map a b)
+-- }}}
+-- main {{{
+dmwitConfig nScreens = defaultConfig {
+    borderWidth             = 2,
+    workspaces              = withScreens nScreens (map show [1..5]),
+    terminal                = "urxvt",
+    normalBorderColor       = dark,
+    focusedBorderColor      = bright,
+    modMask                 = mod4Mask,
+    keys                    = keyBindings,
+    layoutHook              = magnifierOff $ avoidStruts (GridRatio 0.9) ||| noBorders Full,
+    manageHook              =     (title =? "CGoban: Main Window" --> doF sinkFocus)
+                              <+> (className =? "Wine" <&&> (appName =? "hl2.exe" <||> appName =? "portal2.exe") --> ask >>= viewFullOn {-centerWineOn-} 1 "5")
+                              <+> (className =? "VirtualBox" --> ask >>= viewFullOn 1 "5")
+                              <+> (isFullscreen --> doFullFloat) -- TF2 matches the "isFullscreen" criteria, so its manage hook should appear after (e.g., to the left of a <+> compared to) this one
+                              <+> (appName =? "huludesktop" --> doRectFloat fullscreen43on169)
+                              <+> fullscreenMPlayer
+                              <+> floatAll ["Gimp", "Wine"]
+                              <+> manageDocks
+                              <+> manageSpawn,
+    logHook                 = allPPs nScreens,
+    startupHook             = refresh >> setWMName "LG3D" -- gotta keep this until all the machines I use have the version of openjdk that respects _JAVA_AWT_WM_NONREPARENTING
+                           >> mapM_ (spawnOnce . xmobarCommand) [0 .. nScreens-1]
+    }
+
+main = countScreens >>= xmonad . dmwitConfig
+-- }}}
+-- keybindings {{{
+keyBindings conf = let m = modMask conf in fromList . anyMask $ [
+    ((m                , xK_BackSpace  ), spawnHere "urxvt"),
+    ((m                , xK_p          ), spawnHere launcher),
+    ((m .|. shiftMask  , xK_p          ), spawnHere termLauncher),
+    ((m .|. shiftMask  , xK_c          ), kill),
+    ((m                , xK_q          ), restart "xmonad" True),
+    ((m .|. shiftMask  , xK_q          ), io (exitWith ExitSuccess)),
+    ((m                , xK_grave      ), sendMessage NextLayout),
+    ((m .|. shiftMask  , xK_grave      ), setLayout $ layoutHook conf),
+    ((m                , xK_o          ), sendMessage Toggle),
+    ((m                , xK_x          ), withFocused (windows . sink)),
+    ((m                , xK_Home       ), windows focusUp),
+    ((m .|. shiftMask  , xK_Home       ), windows swapUp),
+    ((m                , xK_End        ), windows focusDown),
+    ((m .|. shiftMask  , xK_End        ), windows swapDown),
+    ((m                , xK_a          ), windows focusMaster),
+    ((m .|. shiftMask  , xK_a          ), windows swapMaster),
+    ((m                , xK_Control_L  ), withScreen 0 view),
+    ((m .|. shiftMask  , xK_Control_L  ), withScreen 0 viewShift),
+    ((m                , xK_Alt_L      ), withScreen 1 view),
+    ((m .|. shiftMask  , xK_Alt_L      ), withScreen 1 viewShift),
+    ((m                , xK_u          ), centerMouse),
+    ((m .|. shiftMask  , xK_u          ), statusBarMouse),
+    ((m                , xK_s          ), spawnHere "chromium --password-store=gnome"),
+    ((m                , xK_n          ), spawnHere "gvim todo"),
+    ((m                , xK_t          ), spawnHere "mpc toggle"),
+    ((m                , xK_h          ), spawnHere "urxvt -e alsamixer"),
+    ((m                , xK_d          ), spawnHere "wyvern"),
+    ((m                , xK_l          ), spawnHere "urxvt -e sup"),
+    ((m                , xK_r          ), spawnHere "urxvt -e ncmpcpp"),
+    ((m                , xK_c          ), spawnHere "urxvt -e ghci"),
+    ((m                , xK_g          ), spawnHere "slock" >> spawnHere "xscreensaver-command -lock"),
+    ((m                , xK_f          ), spawnHere "gvim ~/.xmonad/xmonad.hs"),
+    ((      noModMask  , xK_F8         ), showMod "sink input" (-4)),
+    ((      noModMask  , xK_F9         ), showMod "sink input"   4 ),
+    ((      shiftMask  , xK_F8         ), showMod "sink"       (-4)),
+    ((      shiftMask  , xK_F9         ), showMod "sink"         4 ),
+    ((      noModMask  , xK_Super_L    ), return ()) -- make VirtualBox ignore stray hits of the Windows key
+    ] ++ [
+    ((m .|. e          , key           ), windows (onCurrentScreen f ws))
+    | (key, ws) <- zip [xK_1..xK_9] (workspaces' conf)
+    , (e, f)    <- [(0, view), (shiftMask, viewShift)]
+    ]
+
+atSchool school home = do
+    host <- liftIO (getEnv "HOST")
+    return $ case host of
+        "sorghum"   -> home
+        "buckwheat" -> home
+        _           -> school
+
+anyMask xs = do
+    ((mask, key), action) <- xs
+    extraMask             <- [0, controlMask, altMask, controlMask .|. altMask]
+    return ((mask .|. extraMask, key), action)
+-- }}}
+-- logHook {{{
+pipeName n s = "/home/dmwit/.xmonad/pipe-" ++ n ++ "-" ++ show s
+
+xmobarCommand (S s) = unwords ["xmobar",
+    "-x", show s,
+    "-t", template s,
+    "-C", pipeReader
+    ]
+    where
+    template 0 = "}%focus%{%workspaces%"
+    template _ = "%date%}%focus%{%workspaces%"
+    pipeReader = "'[\
+        \Run PipeReader \"" ++ pipeName "focus"      s ++ "\" \"focus\",\
+        \Run PipeReader \"" ++ pipeName "workspaces" s ++ "\" \"workspaces\"\
+        \]'"
+
+allPPs nScreens = sequence_ [dynamicLogWithPP (pp s) | s <- [0..nScreens-1], pp <- [ppFocus, ppWorkspaces]]
+color c = xmobarColor c ""
+
+ppFocus s@(S s_) = whenCurrentOn s defaultPP {
+    ppOrder  = \(_:_:windowTitle:_) -> [windowTitle],
+    ppOutput = appendFile (pipeName "focus" s_) . (++ "\n")
+    }
+
+ppWorkspaces s@(S s_) = marshallPP s defaultPP {
+    ppCurrent           = color "white",
+    ppVisible           = color "white",
+    ppHiddenNoWindows   = color dark,
+    ppUrgent            = color "red",
+    ppSep               = "",
+    ppOrder             = \(wss:_layout:_title:_) -> [wss],
+    ppOutput            = appendFile (pipeName "workspaces" s_) . (++"\n")
+    }
+-- }}}