Xmonad/Config archive/Mntnoe's xmonad.hs

{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, MultiParamTypeClasses #-}
 
-------------------------------------------------------------------------- {{{
-- |
-- Module      :  xmonad
-- Copyright   :  (c) Mads N Noe 2009
-- Maintainer  :  mntnoe (@) gmail.com
-- License     :  as-is
-- 
-- Modular xmonad config.
-- 
-- Highlights:
--   * labeled pager addon for DynamicLog
--   * fast navigation between workspaces
--   * application specific border colors
--   * modified Scratchpad using GNU Screen
--   * host specific settings (layouts and widgets)
-- 
-- You need to patch your xmonad source for the modules to work.  Simply look
-- for a line in Core.hs containing runProces \"ghc\" [\"--make\",
-- \"xmonad.hs\" ...] and remove the \"-i\" entry from the list.  This switch
-- was unfortunately added to fix a bug on case insensitive file systems.
-- 
-- I will try to make some darcs patches for xmonad-contrib if I get time.
-- Until then, I hope you can get inspired by some of my ideas. Enjoy :-)
-- 
-------------------------------------------------------------------------- }}}
 
-- IMPORTS {{{
 
-- Haskell modules
import Data.Char (toLower)
import Data.List
import Data.Maybe (isJust)
import qualified Data.Map as M
import System.Cmd (system)
import System.Environment (getEnv)
import System.Exit (exitWith, ExitCode(..) )
import System.IO (Handle)
import System.Posix.Files (fileExist)
 
-- XMonad modules
import XMonad.Actions.CycleWS
import XMonad.Actions.Submap
import XMonad.Actions.SwapWorkspaces
import XMonad.Actions.WindowGo
import XMonad hiding ( (|||) )
import XMonad.Hooks.DynamicHooks
import XMonad.Hooks.DynamicLog hiding (dzen)
import XMonad.Hooks.ManageDocks
import XMonad.Hooks.ManageHelpers
import XMonad.Hooks.UrgencyHook
import XMonad.Layout.IM (withIM, Property(..) )
import XMonad.Layout.LayoutCombinators
import XMonad.Layout.MultiToggle
import XMonad.Layout.Named
import XMonad.Layout.NoBorders
import XMonad.Layout.Reflect
import XMonad.Layout.ResizableTile
import XMonad.Layout.SimplestFloat
import XMonad.Prompt
import qualified XMonad.StackSet as W
import XMonad.Util.NamedWindows (getName)
import XMonad.Util.Run (hPutStrLn)
import XMonad.Util.WorkspaceCompare (getSortByTag)
 
-- My modules
import BorderColors
import Layout
import Util
import DMenu
import Dzen
import ScratchpadPrime
import ServerMode
import Pager
-- }}}
 
-- MAIN {{{
main ::  IO ()
main = do 
    dynamicHooks <- initDynamicHooks
    host         <- getHost
    logPipe      <- spawnDzenWithPipe host xpc
    homedir      <- getEnv "HOME"
    spawnDzenWithConky xpc $ homedir ++ "/.conkyrc-dzen"
    xmonad $ withUrgencyHook NoUrgencyHook $ myXConfig logPipe dynamicHooks host
-- }}}
 
-- QUERIES {{{
q_bc31        = appName   =? "RDO001GL.EXE"
q_conky       = className =? "Conky"
q_eclipse     = className =? "Eclipse"
q_eclipse_spl = title     =? "." <&&> className                            =? ""
q_emacs       = className =? "Emacs" <||> fmap (isPrefixOf "emacs:") title
q_firefox     = className =? "Iceweasel" <||> className =? "Firefox"
q_firefox_fl  = q_firefox <&&> fmap (/="Navigator") appName 
q_gvim        = className =? "Gvim"
q_log         = appName   =? "xterm-log"
q_mocp        = appName   =? "xterm-mocp"
q_mplayer     = className =? "MPlayer"
q_mutt        = appName   =? "xterm-mutt"
q_ooo         = className =? "OpenOffice.org 3.0"
q_ref         = className =? "Xpdf" <||> className =? "XDvi" <||> className =? "Acroread"
q_scratchpad  = appName   =? "xterm-scratchpad"
q_screen      = appName   =? "xterm-screen"
q_ssh_askpass = className =? "Ssh-askpass-fullscreen"
q_tmpWins     = q_log <||> q_mocp
q_thunar      = className =? "Thunar"
q_vim         = (fmap (isPrefixOf "vim:") title <&&> q_xterms) <||> appName =? "xterm-vim" -- title is not set immediately
q_vlc         = title     =? "VLC media player"
q_xchat       = className =? "Xchat"
q_xmessage    = className =? "Xmessage"
q_xterm       = appName   =? "xterm"
q_xterm_float = appName   =? "xterm-float"
q_xterm_su    = q_xterms <&&> ( fmap (\t -> (isPrefixOf "root:" t) || (isInfixOf "emerge:" t)) title )
q_xterms      = className =? "XTerm"
 
-- | Map windows to symbols for the pager.  Symbols for floating windows are in
--   lower case.
windowLabelMap :: [(String, Query Bool)]
windowLabelMap =
    map whenFloat tiledWindows ++ tiledWindows
    ++
    map whenFloat generalQueries ++ generalQueries
  where
 
    whenFloat (l, q) = (map toLower l, isFloat <&&> q)
 
    tiledWindows = 
        [ ("D", q_eclipse <||> q_eclipse_spl)
        , ("V", q_vim <||> q_gvim)
        , ("E", q_emacs)
        , ("F", q_thunar)
        , ("I", q_xchat)
        , ("L", q_log)
        , ("M", q_mocp <||> q_mplayer)
        , ("@", q_mutt)
        , ("O", q_ooo)
        , ("R", q_ref)
        , ("S", q_xterm_su)
        , ("W", q_firefox)
        ]
 
    generalQueries =
        [ ("T", q_xterms)
        , ("X", return True) -- catchall
        ]
 
-- }}}
 
-- SETTINGS {{{
 
-- | Layout to show initially, and when issuing the according keybinding.  My
--   desktop is widescreen, but not my laptop.
defaultLayout Desktop = "Tall"
defaultLayout Laptop  = "Wide"
 
gimpLayout Desktop  = "GIMP_md"
gimpLayout Laptop   = "GIMP_ml"
 
-- Colors
myNormalBorderColor   = "#dddddd"
myFocusedBorderColor  = "#3939ff"
masterBorderColor     = "#ff1010"
floatBorderColor      = "#10c010"
dzenBG                = myNormalBorderColor
dzenFG                = "#000000"
dzenActiveBG          = "#a0a0a0"
dzenActiveFG          = "#000000"
dzenUrgentFG          = "#00ff00"
dzenUrgentBG          = "#ffff00"
 
-- | Settings for both dzen and dmenu. 
xpc :: XPConfig
xpc = XPC
    { font              = "-misc-fixed-*-*-*-*-13-*-*-*-*-*-*-*"
    , bgColor           = dzenBG
    , fgColor           = dzenFG
    , bgHLight          = dzenActiveBG
    , fgHLight          = dzenActiveFG
    , borderColor       = dzenBG
    , promptBorderWidth = 0
    , position          = Bottom
    , height            = 15
    , historySize       = 0
    , defaultText       = []
    , autoComplete      = Nothing
    }
 
-- myXConfig :: Handle -> IORef DynamicHooks -> Host -> XConfig l
myXConfig logPipe dynamicHooks host = XConfig
    { terminal            = "xterm"
    , focusFollowsMouse   = True
    , borderWidth         = 3
    , modMask             = mod5Mask
    , numlockMask         = mod2Mask
    , workspaces          = map show [1..9]
    , normalBorderColor   = myNormalBorderColor
    , focusedBorderColor  = myFocusedBorderColor
    , keys                = myKeys dynamicHooks host
    , mouseBindings       = myMouseBindings
    , layoutHook          = myLayoutHook host
    , manageHook          = myManageHook <+> dynamicMasterHook dynamicHooks
    , logHook             = myLogHook logPipe
    , startupHook         = myStartupHook host
    }
-- }}}
 
-- KEYS/MOUSE {{{
 
-- | The keybindings are optimized for the Colemak (<http://colemak.com>)
--   keyboard layout.  The keys are placed in the right side of the keyboard,
--   using right alt as the modifier.
myKeys :: h -> Host -> c -> M.Map (KeyMask, KeySym) (X ())
myKeys dynamicHooks host conf =
    let m1 = mod5Mask
        m2 = mod5Mask .|. shiftMask
        m3 = mod5Mask .|. mod1Mask
        in M.fromList $
 
    -- APPLICATIONS
    [ ((m1, xK_x), submap $ M.fromList
        [ ((m1, xK_v), runOrRaiseNext "xvim" (q_vim))
        , ((0 , xK_v), spawn "xvim")
        , ((m1, xK_c), runOrRaiseNext "emacs" (q_emacs))
        , ((0 , xK_c), spawn "emacs")
        , ((m1, xK_b), spawn "firefox")
        , ((m1, xK_l), reqEmptyWS (q_log)  $ spawn $ xterm "xterm-log"  "mtail -f /var/log/messages ~/.xsession-errors")
        , ((m1, xK_e), reqEmptyWS (q_mutt) $ spawn $ xterm "xterm-mutt" "mutt")
        , ((m1, xK_m), reqEmptyWS (q_mocp) $ spawn $ xterm "xterm-mocp" "mocp")
        , ((0 , xK_w), submap $ M.fromList -- control some system services like networking
            [ ((0 , xK_w), spawn $ xterm "xterm-float" "sleepdo 1 svc -w")
            , ((0 , xK_e), spawn $ xterm "xterm-float" "sleepdo 1 svc -e")
            , ((0 , xK_d), spawn $ xterm "xterm-float" "sleepdo 1 svc -d")
            , ((0 , xK_a), spawn $ xterm "xterm-float" "sleepdo 1 svc -a")
            , ((0 , xK_l), spawn $ xterm "xterm-float" "sleepdo 1 svc -l")
            ] )
        ] )
 
    -- enhance clipboard functionality in xterm
    , ((m1, xK_z), spawn "xclip -selection primary -o | xclip -selection clipboard -i")
 
    , ((m1, xK_c), spawn "xterm")
    , ((m1, xK_Return), scratchpad' q_scratchpad $ xterm "xterm-scratchpad" "screen -dRRS scratchpad")
    , ((m1, xK_b), runOrRaiseNext "firefox" (q_firefox))
 
    , ((m1, xK_slash), spawn $ dmenuRun xpc)
 
    , ((m1, xK_v), submap $ M.fromList
 
        -- LAYOUT SWITCHING
        [ ((m1, xK_v), sendMessage $ JumpToLayout $ defaultLayout host)
        , ((m2, xK_v), (broadcastMessage $ JumpToLayout $ defaultLayout host) >> refresh)
        , ((m1, xK_a), sendMessage $ JumpToLayout "Accordion")
        , ((m1, xK_r), sendMessage $ JumpToLayout "R_Tall")
        , ((m1, xK_s), sendMessage $ JumpToLayout "Wide")
        , ((m1, xK_t), sendMessage $ JumpToLayout "Tall")
        , ((m1, xK_f), sendMessage $ JumpToLayout "Float")
        , ((m1, xK_d), sendMessage $ JumpToLayout $ gimpLayout host)
 
        -- MISC
        , ((m1, xK_u), sendMessage $ ToggleStruts)
        , ((m1, xK_b), withFocused $ windows . W.sink)
        ])
 
    , ((m1, xK_m), sendMessage $ Toggle FULL)
 
    -- WINDOW HANDLING
    , ((m1, xK_n), windows W.focusDown)
    , ((m1, xK_e), windows W.focusUp)
    , ((m1, xK_h), swapOrRaise)
    , ((m2, xK_h), swapOrLower)
 
    , ((m2, xK_k), killAndReturn q_tmpWins)
 
    -- LAYOUT MESSAGES
    , ((m1, xK_Left), sendMessage Shrink)
    , ((m1, xK_Right), sendMessage Expand)
    , ((m1, xK_Up), sendMessage MirrorShrink)
    , ((m1, xK_Down), sendMessage MirrorExpand)
 
    -- SESSION
    , ((m2, xK_BackSpace), io (system "touch ~/.exit_flag" >> exitHook >> exitWith ExitSuccess))
    , ((m1, xK_BackSpace), io exitHook >> restart "xmonad" True)
 
    -- WORKSPACES
    -- I have swapped Y and J in my modified Colemak keyboard layout.
    , ((m1, xK_y), doWithWS W.greedyView    Prev EmptyWS)
    , ((m2, xK_y), doWithWS shiftView       Prev EmptyWS)
    , ((m3, xK_y), doWithWS swapWithCurrent Prev EmptyWS)
    , ((m1, xK_l), doWithWS W.greedyView    Prev NonEmptyWS)
    , ((m2, xK_l), doWithWS shiftView       Prev NonEmptyWS)
    , ((m3, xK_l), doWithWS swapWithCurrent Prev NonEmptyWS)
    , ((m1, xK_u), doWithWS W.greedyView    Next NonEmptyWS)
    , ((m2, xK_u), doWithWS shiftView       Next NonEmptyWS)
    , ((m3, xK_u), doWithWS swapWithCurrent Next NonEmptyWS)
    , ((m1, xK_j), doWithWS W.greedyView    Next EmptyWS)
    , ((m2, xK_j), doWithWS shiftView       Next EmptyWS)
    , ((m3, xK_j), doWithWS swapWithCurrent Next EmptyWS)
 
    , ((m1, xK_i), doWithWS shiftView       Next EmptyWS)
    , ((m1, xK_0), toggleWS)
 
    -- I use <5-;> <5-o> <5-'> and <5-{> for international characters.
 
    ] 
    ++ zip (zip (repeat m1) [xK_1..xK_9]) (map (withNthWorkspace W.greedyView) [0..])
    ++ zip (zip (repeat m2) [xK_1..xK_9]) (map (withNthWorkspace shiftView) [0..])
    ++ zip (zip (repeat m3) [xK_1..xK_9]) (map (withNthWorkspace swapWithCurrent) [0..])
 
-- MOUSE
myMouseBindings :: XConfig t -> M.Map (KeyMask, Button) (Window -> X ())
myMouseBindings conf = M.fromList $
    [ ((mod5Mask, button1), focusAnd $ mouseMoveWindow)
    , ((mod5Mask, button3), focusAnd $ mouseResizeWindow)
    , ((0, 8), focusAnd $ mouseMoveWindow)
    ]
  where
 
    -- | Focus and raise the window before performing a mouse operation.
    focusAnd job w = focus w >> windows W.swapMaster >> job w
-- }}}
 
-- LAYOUTHOOK {{{
 
-- | Cross host layoutHook.  Hosts have different default layouts, different
--   ratios, and keybindings may switch to different layouts.
myLayoutHook host =
    eventHook ServerMode $
    avoidStruts $
    (smartBorders $ 
        (mkToggle (single FULL) $ 
            tall  (r host) ||| 
            rtall (r host) ||| 
            wide  (r host) ||| 
            MyAccordion
        ) |||
        gimp_ml |||
        gimp_md
    ) ||| 
    (mkToggle (single FULL) $ 
        named "Float" simplestFloat
    )
  where
 
    wide r = 
        named "Wide" $
        Mirror $
        ResizableTall nmaster delta r []
 
    rtall r =
        named "R_Tall" $
        ResizableTall nmaster delta r []
 
    tall r =
        named "Tall" $
        reflectHoriz $
        ResizableTall nmaster delta r []
 
    nmaster = 1
 
    delta = 3/40
 
    r Desktop = 4/7
    r Laptop  = 2/3
 
    gimp_md = 
        named "GIMP_md" $ 
        withIM 0.10 (Role "gimp-toolbox") $
        reflectHoriz $
        withIM 0.15 (Role "gimp-dock") $
        Full
    gimp_ml =
        named "GIMP_ml" $
        withIM 0.25 (Role "gimp-toolbox") $
        Full
 
data MyTransformers = FULL
  deriving (Read, Show, Eq, Typeable)
 
instance Transformer MyTransformers Window where
    transform FULL       _ k = k $ named "Full" Full
 
-- }}}
 
-- MANAGEHOOK {{{
myManageHook :: ManageHook
myManageHook = composeAll
    [ q_xmessage    --> doCenterFloat
    , q_conky       --> doIgnore
    , q_ssh_askpass --> doFullFloat
    , q_firefox_fl  --> doCenterFloat
    , q_eclipse_spl --> doCenterFloat
    , q_vlc         --> doCenterFloat
    , q_scratchpad  --> doCenterFloat
    , q_xterm_float --> doCenterFloat
    , q_bc31        --> doCenterFloat
 
    -- Most often, I don't want terminals to steal the current window's
    -- position.  However, only do this to terminals, as focus is not restored
    -- to the original window when doing this.
    , (q_xterm <||> q_screen) --> doF W.swapDown
    , manageDocks
    ]
-- }}}
 
-- STARTUP/EXIT HOOK {{{
myStartupHook :: Host -> X ()
myStartupHook host = do
    broadcastMessage $ JumpToLayout $ defaultLayout host
    refresh
 
exitHook :: IO ()
exitHook = do
    -- Make sure the panels gets reloaded with xmonad.
    system "killall conky-cli"
    system "killall hbar"
    return ()
-- }}}
 
-- LOGHOOK {{{
myLogHook :: Handle -> X ()
myLogHook logPipe = do
    -- I found it least confusing when coloring the master window only.  This
    -- makes it easy to tell which window has focus, without moving your eyes
    -- to the border of the screen, as the coloring is based on the window
    -- position.
    colorWhen isMaster masterBorderColor
    -- Make it easy to distinguish between floating and non-floating windows.
    -- Sometimes I accidently makes a window floating without moving it out of
    -- its position.
    colorWhen isFloat floatBorderColor
 
    dynamicLogString myDynamicLog >>= io . hPutStrLn logPipe
 
myDynamicLog :: PP
myDynamicLog = defaultPP 
    { ppCurrent         = dzenColor dzenActiveFG dzenActiveBG . pad
    -- ppHidden overwrites colors of ppUrgent
    , ppHidden          = pad
    , ppHiddenNoWindows = dzenColor dzenActiveBG dzenBG       . pad
    , ppUrgent          = dzenColor dzenUrgentFG dzenUrgentBG
    , ppWsSep           = ""
    , ppSep             = " "
    , ppLayout          = dzenColor dzenActiveFG dzenActiveBG . pad
    , ppTitle           = dzenColor dzenFG       dzenBG       . pad
    , ppSort            = getSortByTag
    , ppOrder           = order
    , ppExtras          = [ labeledPager myDynamicLog windowLabelMap ]
    } 
  where
    order (_:l:t:ws:_) = ws:l:t:[]
    order xs           = ["Error in order list: " ++ show xs]
 
-- }}}
 
-- vim: set ft=haskell fdm=marker fdl=0 fdc=4:

{-# LANGUAGE FlexibleContexts #-}
 
------------------------------------------------------------------------------
-- |
-- Module      :  BorderColors 
-- Copyright   :  (c) Mads N Noe 2009
-- Maintainer  :  mntnoe (@) gmail.com
-- License     :  as-is
-- 
-- Application specific border colors for XMonad.  You can color any kind of
-- windows, but I found it least confusing when coloring the master window
-- only.  This makes it easy to tell which window has focus, without moving
-- your eyes to the border of the screen, breaking your work flow.
-- 
------------------------------------------------------------------------------
 
module BorderColors (colorWhen) where
 
-- Haskell modules
import Control.Monad (when)
 
-- XMonad modules
import XMonad
 
-- | Set the border color when the query is satisfied.  Should be added to the
--   ManageHook.
colorWhen :: Query Bool -> String -> X ()
colorWhen q cl = withFocused $ \w -> runQuery q w >>= flip when (setWindowBorder' cl w)
 
-- | Give set the border color of a window to the given HTML color code.
setWindowBorder' ::(MonadReader XConf m, MonadIO m) => String -> Window -> m ()
setWindowBorder' c w = do
    XConf { display = d } <- ask
    ~(Just pc) <- io $ initColor d c
    io $ setWindowBorder d w pc

------------------------------------------------------------------------------
-- |
-- Module      :  DMenu 
-- Copyright   :  (c) Mads N Noe 2009
-- Maintainer  :  mntnoe (@) gmail.com
-- License     :  as-is
-- 
-- DMenu helper functions.
-- 
------------------------------------------------------------------------------
 
module DMenu where
 
-- Haskell modules
import Data.List (intercalate)
 
-- XMonad modules
import XMonad.Prompt
 
-- | Run command in path.
dmenuRun xpc = intercalate " " $ "dmenu_run" : dmenuArgs xpc "Run:"
 
-- | DMenu options based on an XPC.
dmenuArgs xpc prompt = 
    [ "-b"
    , "-fn" , font     xpc
    , "-nb" , bgColor  xpc
    , "-nf" , fgColor  xpc
    , "-sb" , bgHLight xpc
    , "-sf" , fgHLight xpc
    , "-p"  , prompt
    ]

------------------------------------------------------------------------------
-- |
-- Module      :  Dzen 
-- Copyright   :  (c) Mads N Noe 2009
-- Maintainer  :  mntnoe (@) gmail.com
-- License     :  as-is
-- 
-- Functions for spawning dzen instances.
-- 
------------------------------------------------------------------------------
 
module Dzen (
    spawnDzenWithPipe,
    spawnDzenWithConky,
    dzen
    ) where
 
-- Haskell modules
import Control.Monad
import Data.List
import Foreign.C.Types (CInt)
import GHC.IOBase (Handle)
import System.Cmd
import System.Environment (getEnv)
import System.Posix.Files(fileExist)
 
-- XMonad modules
import Control.Monad
import Graphics.X11.Xlib.Display
import XMonad (spawn)
import XMonad.Prompt
import XMonad.Util.Run(spawnPipe)
 
-- My modules
import Util (Host (Desktop, Laptop))
 
-- | Spawn two dzen instances at the top of the screen, reading input
--   from xmonad and hbar respectively.
spawnDzenWithPipe :: Host -> XPConfig -> IO Handle
spawnDzenWithPipe host xpc = do
    (sw, sh) <- getScreenDim
    let w = 300
    system $ hbar host ++ dzen xpc
        Nothing  -- put dzen at the top of the screen
        (sw - w) -- horizontal position
        w        -- horizontal width
        'r'      -- text align
        actions ++ " &"
    spawnPipe $ dzen xpc
        Nothing  -- put dzen at the top of the screen
        0        -- horizontal position
        (sw - w) -- horizontal width
        'l'      -- text align
        actions
 
  where     
    -- Show battery info only on the laptop.
    hbar Desktop = "hbar -cmt | "
    hbar Laptop = "hbar -cmbt | "
 
    -- Mouse clicking cycles between populated workspaces.  xmcli is my
    -- ServerMode client.
    actions = "button3=exec:xmcli 2;button1=exec:xmcli 3"
 
-- | Spawn a dzen instance at the bottom of the screen using conky for input.
spawnDzenWithConky ::  XPConfig -> FilePath -> IO ()
spawnDzenWithConky xpc conkyrc = do
    (sw, sh) <- getScreenDim
    let dest = dzen xpc
            (Just sh) -- put dzen at the bottom of the screen
            0         -- horizontal position
            sw        -- horizontal width
            'c'       -- text align
            ""        -- no actions
    fileExist conkyrc >>= (flip when $ do_ $ system $ dzenWithConky conkyrc dest)
 
  where
    do_ x = x >> return ()
 
    dzenWithConky conkyrc dest = intercalate " " ["conky-cli -c", conkyrc, "|", dest, "&"]
 
-- | Return a string that launches dzen with the given configuration.
dzen :: Num a => XPConfig -- ^ prompt style configuration
              -> Maybe a  -- ^ Nothing: put dzen at the top of the screen
                          --   Just h:  put dzen at the bottom of the screen with height h
              -> a        -- ^ horizontal position
              -> a        -- ^ horizontal width
              -> Char     -- ^ text align
              -> String   -- ^ actions
              -> String
dzen xpc mh x w ta e =
    let y = case mh of
            Nothing -> 0
            Just h  -> h - (fromInteger $ toInteger $ height xpc) in
        intercalate " "
            [ "dzen2"
            , "-x"  , show x
            , "-w"  , show w
            , "-y"  , show y
            , "-h"  , show  $ height  xpc
            , "-fn" , quote $ font    xpc
            , "-bg" , quote $ bgColor xpc
            , "-fg" , quote $ fgColor xpc
            , "-ta" , [ta]
            , "-e"  , quote e
            ]
    where
        quote x = "'" ++ x ++ "'"
 
-- | Return the dimensions of the (primary?) screen.
getScreenDim :: IO (CInt, CInt)
getScreenDim = do
    d <- openDisplay ""
    let s = defaultScreen d
        w = displayWidth d s
        h = displayHeight d s
    closeDisplay d
    return (w, h)

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
 
------------------------------------------------------------------------------
-- |
-- Module      :  Layout 
-- Copyright   :  (c) Mads N Noe 2009
-- Maintainer  :  mntnoe (@) gmail.com
-- License     :  as-is
-- 
-- Custom layout algorithms. 
-- 
------------------------------------------------------------------------------
 
module Layout (
    MyAccordion(..)
    ) where
 
-- XMonad modules
import XMonad
import qualified XMonad.StackSet as W
 
-- Hacked Accordion layout.  Useful for LaTeX editing, where you switch between
-- an editor window and a preview window.  Only the ratios are modified.  This
-- hack does not space windows evenly when the workspace contains more than two
-- windows, but fixing it would require a rewrite.  Accordion originally by
-- <glasser (@) mit.edu>.  
data MyAccordion a = MyAccordion deriving ( Read, Show )
 
instance LayoutClass MyAccordion Window where
    pureLayout _ sc ws = zip ups tops ++ [(W.focus ws, mainPane)] ++ zip dns bottoms
     where
       ups    = W.up ws
       dns    = W.down ws
       (top,  allButTop) = splitVerticallyBy (1/3) sc
       (center,  bottom) = splitVerticallyBy (1/2) allButTop
       (allButBottom, _) = splitVerticallyBy (2/3) sc
       mainPane | ups /= [] && dns /= [] = center
                | ups /= []              = allButTop
                | dns /= []              = allButBottom
                | otherwise              = sc
       tops    = if ups /= [] then splitVertically (length ups) top    else []
       bottoms = if dns /= [] then splitVertically (length dns) bottom else []
    description _ = "Accordion"

------------------------------------------------------------------------------
-- |
-- Module      :  Obsolete 
-- Copyright   :  (c) Mads N Noe 2009
-- Maintainer  :  mntnoe (@) gmail.com
-- License     :  as-is
-- 
-- Functions not used anymore, but might be useful later.
-- 
------------------------------------------------------------------------------
 
module Obsolete (
    ) where
 
-- Haskell modules
import Data.Char (toLower, toUpper)
import qualified Data.Map as M
 
-- XMonad modules
import XMonad
import XMonad.Prompt
import qualified XMonad.StackSet as W
import XMonad.Util.NamedWindows (getName)
import XMonad.Util.Run (runProcessWithInput)
 
-- My modules
import DMenu (dmenuArgs)
 
-- DMENU FUNCTIONS
 
-- | Spawn dmenu with the given prompt and completion list.  Return what the
--   user typed (which might not be an item in the list).
dmenu :: XPConfig -> String -> [String] -> X String
dmenu xpc prompt opts = io $ runProcessWithInput "dmenu" (dmenuArgs xpc prompt) (unlines opts)
 
-- | Like 'dzen', but look up the return value in a map.
dmenuMap :: XPConfig -> String -> M.Map String a -> X (Maybe a)
dmenuMap xpc prompt selectionMap = do
  selection <- (dmenu xpc prompt) (M.keys selectionMap)
  return $ M.lookup selection selectionMap
 
-- | Prompt for a window and focus it.
gotoMenu :: XPConfig -> X ()
gotoMenu xpc = actionMenu xpc "Window:" W.focusWindow
 
-- | Prompt for a window and perform an 'WindowSet' operation on it.
actionMenu :: XPConfig -> String -> (Window -> WindowSet -> WindowSet) -> X()
actionMenu xpc prompt action = windowMap >>= (dmenuMap xpc prompt) >>= flip whenJust (windows . action)
 
-- | Map from a formatted name to the corresponding 'Window' for use in a prompt.
windowMap :: X (M.Map String Window)
windowMap = do
  ws <- gets windowset
  M.fromList `fmap` concat `fmap` mapM keyValuePairs (W.workspaces ws)
 where keyValuePairs ws = mapM (keyValuePair ws) $ W.integrate' (W.stack ws)
       keyValuePair ws w = flip (,) w `fmap` formatWindowName ws w
 
-- | Return a formatted string representation of a 'Window'.
formatWindowName :: WindowSpace -> Window -> X String
formatWindowName ws w = do
  name <- fmap (take 15 . map toLower . show) $ getName w
  return $ name ++ " [" ++ [head $ W.tag ws] ++ "]"
 
 
-- FOCUS SLAVES
 
-- Cycle focus between \"slave windows\" in an XMonad workspace.  I found it
-- more confusing than helpful, though.
 
-- | Focus the previous window which is not the master window.  Wrap around the
--   end.
focusUpSlave :: WindowSet -> WindowSet
focusUpSlave = W.modify' focusUpSlave'
  where 
    focusUpSlave' :: W.Stack a -> W.Stack a
    focusUpSlave' (W.Stack t (l:[]) rs) = W.Stack x xs [] where (x:xs) = reverse (l:t:rs)
    focusUpSlave' (W.Stack t (l:ls) rs) = W.Stack l ls (t:rs)
    focusUpSlave' (W.Stack t []     rs) = W.Stack x xs [] where (x:xs) = reverse (t:rs)
 
-- | Focus the next window which is not the master window.  Wrap around the
--   end.
focusDownSlave :: WindowSet -> WindowSet
focusDownSlave = W.modify' focusDownSlave'
  where
    focusDownSlave' s@(W.Stack _ []   []) = s
    focusDownSlave' (W.Stack t ls (r:rs)) = W.Stack r (t:ls) rs
    focusDownSlave' (W.Stack t ls     []) = W.Stack x [m] xs where (m:x:xs) = reverse (t:ls)
 
-- | Swap position with the previous window which is not the master window.
--   Wrap around the end.
swapUpSlave :: WindowSet -> WindowSet
swapUpSlave = W.modify' swapUpSlave'
  where
    swapUpSlave' (W.Stack t (l:[]) rs) = W.Stack t (reverse (l:rs)) []
    swapUpSlave' (W.Stack t (l:ls) rs) = W.Stack t ls (l:rs)
    swapUpSlave' (W.Stack t []     rs) = W.Stack t (reverse rs) []
 
-- | Swap position with the next window which is not the master window. Wrap
--   around the end.
swapDownSlave :: WindowSet -> WindowSet
swapDownSlave = W.modify' swapDownSlave'
  where
    swapDownSlave' s@(W.Stack _ []     []) = s
    swapDownSlave' (W.Stack t ls   (r:rs)) = W.Stack t (r:ls) rs
    swapDownSlave' (W.Stack t ls@(_:_) []) = W.Stack t [x] xs where (x:xs) = (reverse ls)

------------------------------------------------------------------------------
-- |
-- Module      :  Pager 
-- Copyright   :  (c) Mads N Noe 2009
-- Maintainer  :  mntnoe (@) gmail.com
-- License     :  as-is
-- 
-- A pager for DynamicLog showing a symbol for each window on each workspace.
-- 
------------------------------------------------------------------------------
 
module Pager (
    -- * Usage
    -- $usage
 
    labeledPager
  ) where
 
-- XMonad modules
import XMonad
import Data.Maybe ( isJust, fromMaybe )
import qualified Data.Map as M
import Data.Map ( (!) )
import Data.List
import qualified XMonad.StackSet as W
import XMonad.Hooks.DynamicLog
import XMonad.Hooks.UrgencyHook
 
-- My modules
import Util
 
-- $usage
--
-- The simplest way to use this module is to add something like this in your
-- @~\/.xmonad\/xmonad.hs@.  Note that you need to patch your xmonad source to
-- allow support for user modules (see my @xmonad.hs@).
--
-- > import XMonad.Hooks.DynamicLog
-- > import Pager
-- >
-- > main = xmonad $ defaultConfig {
-- >    ...
-- >    logHook = myDynamicLog
-- >    ...
-- >  }
-- >
-- > myDynamicLog :: PP
-- > myDynamicLog = defaultPP 
-- >     { ppOrder           = order
-- >     , ppExtras          = [ labeledPager myDynamicLog windowLabelMap ]
-- >     } 
-- >   where
-- >     order (_:l:t:ws:_) = ws:l:t:[]
-- >     order xs           = ["Error in order list: " ++ show xs]
--
-- You also need a way to assign symbols to your windows. Here is a simple
-- example using single letter symbols, but you also use dzen icons.
--
-- > -- | Map windows to symbols for the pager.  Symbols for floating windows are in
-- > --   lower case.
-- > windowLabelMap :: [(String, Query Bool)]
-- > windowLabelMap =
-- >     map whenFloat tiledWindows ++ tiledWindows
-- >     ++
-- >     map whenFloat generalQueries ++ generalQueries
-- >   where
-- > 
-- >     whenFloat (l, q) = (map toLower l, isFloat <&&> q)
-- > 
-- >     tiledWindows = 
-- >         [ ("V", className =? "Gvim")
-- >         , ("E", className =? "Emacs")
-- >         , ("W", className =? "Firefox")
-- >         ]
-- > 
-- >     generalQueries =
-- >         [ ("T", appName =? "xterm")
-- >         , ("X", return True) -- catchall
-- >         ]
 
-- | The 'DynamicLog' logger to add to 'ppExtras' using the given pretty
--   printer and window label map.
labeledPager :: PP -> [(String, Query Bool)] -> X (Maybe String)
labeledPager pp lm = do
    s       <- gets windowset
    urgents <- readUrgents
    sort'   <- ppSort pp
    wl      <- queryWindows s lm
    return $ Just $ pprWindowSet' sort' urgents wl pp s
 
-- | like 'pprWindowSet', but append to each workspace the outcome of
--   'printWindows'.
pprWindowSet' :: ([W.Workspace String l Window] -> [W.Workspace String l Window])
                                                   -- ^ sorting function
              -> [Window]                          -- ^ urgent windows
              -> M.Map Window String               -- ^ window to symbol map
              -> PP                                -- ^ pretty-Printer
              -> W.StackSet String l Window sid sd -- ^ stack set
              -> String
pprWindowSet' sort' urgents wl pp s 
    = sepBy (ppWsSep pp) . map fmt . sort' $
            map W.workspace (W.current s : W.visible s) ++ W.hidden s
   where this     = W.tag (W.workspace (W.current s))
         visibles = map (W.tag . W.workspace) (W.visible s)
 
         fmt ws = printer pp (W.tag ws ++ printWindows wl (W.integrate' $ W.stack ws))
          where printer | W.tag ws == this         = ppCurrent
                        | W.tag ws `elem` visibles = ppVisible
                        | any (\x -> maybe False (== W.tag ws) (W.findTag x s)) urgents  
                                                   = \ppC -> ppUrgent ppC . ppHidden ppC
                        | isJust (W.stack ws)      = ppHidden
                        | otherwise                = ppHiddenNoWindows
 
-- | Output a list of strings, ignoring empty ones and separating the
--   rest with the given separator.
sepBy :: String   -- ^ separator
      -> [String] -- ^ fields to output
      -> String
sepBy sep = concat . intersperse sep . filter (not . null)
 
-- | Print a concatenated string of symbols for a list of windows.
printWindows :: M.Map Window String -- ^ window to symbol map
             -> [Window]            -- ^ windows on the workspace
             -> String
printWindows wl ws = pad $ concat $ map (\w -> fromMaybe "" $ M.lookup w wl) ws
  where
    pad "" = ""
    pad xs = ":"++xs
 
-- | Query each window in the 'WindowSet' and assign a symbol to it in a map.
queryWindows :: WindowSet -> [(String, Query Bool)] -> X (M.Map Window String)
queryWindows ws lm = do
    mapM (qw lm) (W.allWindows ws) >>= return . M.fromList
  where
    qw :: [(String, Query Bool)] -> Window -> X (Window, String)
    qw [] w           = return (w, "?")
    qw ((l, q):lqs) w = runQuery q w >>= if_ (return (w, l)) (qw lqs w)

------------------------------------------------------------------------------
-- |
-- Module      :  ScratchpadPrime 
-- Copyright   :  (c) Mads N Noe 2009
-- Maintainer  :  mntnoe (@) gmail.com
-- License     :  as-is
-- 
-- A modified scatchpad which uses GNU Screen to detach the window rather than
-- putting it on a hidden workspace.  This makes cycling between workspaces
-- easy, as there is no need for a dummy workspace to store the terminal when
-- hidden.
-- 
------------------------------------------------------------------------------
 
module ScratchpadPrime (
    scratchpad'
  ) where
 
-- Haskell modules
import Control.Monad
 
-- XMonad modules
import XMonad
import qualified XMonad.StackSet as W
 
-- | A modified scatchpad which uses GNU Screen to detach the
--   window rather than putting it on a hidden workspace.
scratchpad' :: Query Bool -> String -> X ()
scratchpad' q cmd = withWindowSet $ \s -> do
  filterCurrent <- filterM (runQuery $ q) 
                     $ (maybe [] W.integrate 
                        . W.stack 
                        . W.workspace 
                        . W.current) s
  case filterCurrent of
    (x:_) -> kill' x
    []    -> do
      filterAll <- filterM (runQuery $ q) $ W.allWindows s
      case filterAll of
        (x:_) -> windows (W.shiftWin (W.currentTag s) x)
        -- no need to 'sleep 0.2' here, as window isn't resized
        []    -> spawn cmd
 
-- | As 'kill', but kill a given window (rather than killing the focused window).
kill' :: Window ->X ()
kill' w = withDisplay $ \d -> do
    wmdelt <- atom_WM_DELETE_WINDOW  ;  wmprot <- atom_WM_PROTOCOLS
 
    protocols <- io $ getWMProtocols d w
    io $ if wmdelt `elem` protocols
        then allocaXEvent $ \ev -> do
                setEventType ev clientMessage
                setClientMessageEvent ev w wmprot 32 wmdelt 0
                sendEvent d w False noEventMask ev
        else killClient d w >> return ()

------------------------------------------------------------------------------
-- |
-- Module      :  ServerMode 
-- Copyright   :  (c) Mads N Noe 2009
--                (c) Andrea Rossato and David Roundy 2007
-- Maintainer  :  mntnoe (@) gmail.com
-- License     :  BSD-style (see xmonad\/LICENSE)
-- 
-- Modification of XMonad.Hooks.ServerMode with custom actions.
-- 
------------------------------------------------------------------------------
 
module ServerMode ( 
      ServerMode (..)
    , eventHook
    ) where
 
-- Haskell modules
import Control.Monad (when)
import Data.List
import Data.Maybe
import System.IO
import qualified Data.Map as M
 
-- XMonad modules
import XMonad
import XMonad.Actions.Commands hiding (runCommand')
import XMonad.Hooks.EventHook
import XMonad.Actions.CycleWS
import qualified XMonad.StackSet as W
 
-- My modules
import Util
 
-- | Custom commands.
commands :: X [(String, X ())]
commands = do
    return $ 
        [ ("prev-empty-ws"       , doWithWS W.greedyView    Prev EmptyWS)
        , ("prev-nonempty-ws"    , doWithWS W.greedyView    Prev NonEmptyWS)
        , ("next-nonempty-ws"    , doWithWS W.greedyView    Next NonEmptyWS)
        , ("next-empty-ws"       , doWithWS W.greedyView    Next EmptyWS)
        ]
 
data ServerMode = ServerMode deriving ( Show, Read )
 
instance EventHook ServerMode where
    handleEvent _ (ClientMessageEvent {ev_message_type = mt, ev_data = dt}) = do
        d <- asks display
        a <- io $ internAtom d "XMONAD_COMMAND" False
        when (mt == a && dt /= []) $ do
             cl <- commands
             let listOfCommands = zipWith (++) (map show ([1..] :: [Int])) . map ((++) " - " . fst)
             case lookup (fromIntegral (head dt) :: Int) (zip [1..] cl) of
                  Just (c,_) -> runCommand' c
                  Nothing    -> mapM_ (io . hPutStrLn stderr) . listOfCommands $ cl
    handleEvent _ _ = return ()
 
-- | Given the name of a command from 'defaultCommands', return the
--   corresponding action (or the null action if the command is not
--   found).
runCommand' :: String -> X ()
runCommand' c = do
  m <- fmap commandMap commands
  fromMaybe (return ()) (M.lookup c m)

------------------------------------------------------------------------------
-- |
-- Module      :  Util 
-- Copyright   :  (c) Mads N Noe 2009
-- Maintainer  :  mntnoe (@) gmail.com
-- License     :  as-is
-- 
-- Utility functions for XMonad.
-- 
------------------------------------------------------------------------------
 
module Util where
 
-- Haskell modules
import Control.Monad (unless, when)
import Control.Monad.Trans (lift)
import Data.List
import qualified Data.Map as M
import Data.Monoid (Endo(Endo))
import System.Posix.Unistd(getSystemID, nodeName)
import System.IO.Error (isDoesNotExistError)
 
-- XMonad modules
import XMonad
import XMonad.Actions.CycleWS
import XMonad.Actions.WindowGo
import qualified XMonad.StackSet as W
import XMonad.Util.WorkspaceCompare (getSortByTag)
 
-- | Perform k x if x return a 'Just' value.
(?+) :: (Monad m) => m (Maybe a) -> (a -> m ()) -> m ()
x ?+ k = x >>= maybe (return ()) k
infixr 1 ?+
 
-- | Helper function for use with monads.
if_ :: t -> t -> Bool -> t
if_ t f c = if c 
                  then t
                  else f
 
-- | Return a string that launches xterm with the given 'title', 'appName' and
--   command to execute.
xterm :: String -> String -> String
xterm a e = concat ["xterm -wf -title '", e,  "' -name '", a, "' -e '", e, "'"]
 
-- | Shift a window to a workspace and switch to that workspace in one
--   operation.
shiftView :: WorkspaceId -> WindowSet -> WindowSet
shiftView ws w = W.greedyView ws $ W.shift ws w
 
-- | Perform a workspace transformation on the next workspace in 'WSDirection'
--   of type 'WSType'.
doWithWS :: (String -> (WindowSet -> WindowSet)) -> WSDirection -> WSType -> X ()
doWithWS f dir wstype = do
    i <- findWorkspace getSortByTag dir wstype 1
    windows $ f i
 
-- | Is the current workspace empty?
isCurrentWsEmpty :: X Bool
isCurrentWsEmpty = withWindowSet $ \s -> do
    let l = W.integrate' $ W.stack $ W.workspace $ W.current s
    return $ null l
 
-- | Modify the 'WindowSet' with a non-pure function.  Counterpart to 'doF'.
doX :: (Window -> X (WindowSet -> WindowSet)) -> ManageHook
doX f = ask >>= Query . lift . fmap Endo . f
 
-- | Ensure that a window always starts on an empty workspace.  If a window
--   satisfying the query exists, focus it.  Otherwise run the specified
--   command, swithing to an empty workspace if the current one is not empty.
reqEmptyWS :: Query Bool -> X () -> X ()
reqEmptyWS q f = do
    raiseNextMaybe (reqEmptyWS' >> f) q
  where
    reqEmptyWS' = do
        empty <- isCurrentWsEmpty
        i <- findWorkspace getSortByTag Next EmptyWS 1
        unless empty $ windows $ W.greedyView i
 
-- | Kill the focused window. If the window satisfies the query, return to the
--   previously displayed workspace.
killAndReturn q = withFocused $ \w -> do
    qr <- runQuery q w
    kill
    when qr toggleWS
 
-- | Perform a 'WindowSet' transformation on the workspace with the given
--   index.
withNthWorkspace :: (String -> WindowSet -> WindowSet) -> Int -> X ()
withNthWorkspace job wnum = nthWorkspaceTag wnum ?+ windows . job
  where
    nthWorkspaceTag :: Int -> X (Maybe String)
    nthWorkspaceTag wnum = do 
        sort <- getSortByTag
        ws <- gets (map W.tag . sort . W.workspaces . windowset)
        case drop wnum ws of
            (w:_) -> return $ Just w
            [] -> return Nothing
 
-- | Is the focused window the \"master window\" of the current workspace?
isMaster :: Query Bool
isMaster = ask >>= (\w -> liftX $ withWindowSet $ \ws -> return $ Just w == master ws)
  where
    master :: WindowSet -> Maybe Window
    master ws = 
        case W.integrate' $ W.stack $ W.workspace $ W.current ws of
             [] -> Nothing
             (x:xs) -> Just x
 
-- | Is the focused window a floating window?
isFloat :: Query Bool
isFloat = ask >>= (\w -> liftX $ withWindowSet $ \ws -> return $ M.member w $ W.floating ws)
 
-- | Swap the focused window with the last window in the stack.
swapBottom :: W.StackSet i l a s sd -> W.StackSet i l a s sd
swapBottom = W.modify' $ \c -> case c of
    W.Stack _ _ [] -> c    -- already bottom.
    W.Stack t ls rs -> W.Stack t (xs ++ x : ls) [] where (x:xs) = reverse rs
 
-- | Swap the focused window with the following window, or if the window is
--   floating, lower it to the bottom.
swapOrLower :: X ()
swapOrLower = withFocused $ \w ->
    runQuery isFloat w >>= if_ (windows swapBottom) (windows W.swapDown)
 
-- | Swap the focused window with the preceding window, or if the window is
--   floating, raise it to the top.
swapOrRaise :: X ()
swapOrRaise = withFocused $ \w ->
    runQuery isFloat w >>= if_ (windows W.swapMaster) (windows W.swapUp)
 
-- | Determine the host.
getHost = do 
    host <- getSystemID
    case nodeName host of
         "mntnoe-desktop" -> return Desktop
         "mntnoe-laptop"  -> return Laptop
         _                -> return Desktop
 
-- | For use in cross host configutions.
data Host = Desktop | Laptop deriving Eq