    -- 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.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 = def {
        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
                               >> 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 def {
        ppOrder  = \(_:_:windowTitle:_) -> [windowTitle],
        ppOutput = appendFile (pipeName "focus" s_) . (++ "\n")
        }

    ppWorkspaces s@(S s_) = marshallPP s def {
        ppCurrent           = color "white",
        ppVisible           = color "white",
        ppHiddenNoWindows   = color dark,
        ppUrgent            = color "red",
        ppSep               = "",
        ppOrder             = \(wss:_layout:_title:_) -> [wss],
        ppOutput            = appendFile (pipeName "workspaces" s_) . (++"\n")
        }
    -- }}}