{-# 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: