path: root/xmonad.hs

import System.IO
import System.Directory
import System.Exit (exitWith, ExitCode(ExitSuccess))
import Codec.Binary.UTF8.String as UTF8 (decodeString)
import Data.Ratio ((%))
import Data.List
import qualified Data.Map as M

import XMonad
import XMonad.Core
import XMonad.Config
import XMonad.ManageHook
import qualified XMonad.StackSet as W
import qualified XMonad.Prompt as P

import XMonad.Layout.DecorationMadness
import XMonad.Layout.Grid
import XMonad.Layout.IM
import XMonad.Layout.MosaicAlt
import XMonad.Layout.Named
import XMonad.Layout.NoBorders
import XMonad.Layout.PerWorkspace
import XMonad.Layout.Reflect
import XMonad.Layout.Tabbed
import XMonad.Layout.ThreeColumns
import XMonad.Layout.TrackFloating
import qualified XMonad.Layout.Magnifier as Mag

import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS
import XMonad.Actions.DynamicWorkspaces
import XMonad.Actions.FindEmptyWorkspace
import XMonad.Actions.FloatSnap
import XMonad.Actions.GridSelect
import XMonad.Actions.SinkAll
import XMonad.Actions.SpawnOn
import XMonad.Actions.TopicSpace hiding (pprWindowSet)
import XMonad.Actions.UpdateFocus
import qualified XMonad.Actions.FlexibleManipulate as Flex

import XMonad.Hooks.DynamicLog
import XMonad.Hooks.EwmhDesktops
import XMonad.Hooks.ManageDocks
import XMonad.Hooks.ManageHelpers
import XMonad.Hooks.ServerMode
import XMonad.Hooks.SetWMName
import XMonad.Hooks.UrgencyHook
import XMonad.Hooks.XPropManage

import XMonad.Prompt.AppLauncher
import XMonad.Prompt.Man
import XMonad.Prompt.Shell
import XMonad.Prompt.Ssh
import XMonad.Prompt.XMonad

import XMonad.Util.NamedScratchpad

-- --replace handling
import XMonad.Util.Replace (replace)
import Control.Monad (when)
import System.Environment (getArgs)

import Data.Maybe (fromMaybe, fromJust, isNothing, isJust, mapMaybe, listToMaybe)
import Data.Ord (comparing)

-- for hostname handling (no windows key on "Australien")
import Network.HostName

-- custom modules
import HistoryGrid
import EZConfig
import Pass
import qualified Confirm

font :: String
font = "xft:Hack:size=10"

term :: String
term = "urxvt"

browser :: String
browser = "browser"


modM :: String -> KeyMask
-- mod1Mask = Alt, mod2Mask = , mod3Mask= , mod4Mask = Win, mod5Mask = AltGrk
modM "Australien" = mod1Mask
modM _            = mod4Mask

myDzenUrgencyConfig = DzenUrgencyHook
        { args = ["-bg", "red", "-fg", "black", "-fn", font,
                  "-w", "600", "-ta", "c", "-x", "520", "-y", "10",
                  "-h", "30" ]
        , duration = seconds 5
        }

--{{{ main

main = do
  args <- getArgs
  when ("--replace" `elem` args) replace

  dzenStatusDir <- getAppUserDataDirectory "xmonad"
  dzenStatusFile <- openFile (dzenStatusDir ++ "/dzenStatus") WriteMode
  hostname <- getHostName
  xmonad
    -- Do _not_ use "ewhm" here, this would add the ewhm hooks to the
    -- end of your custom hooks (esp. the startup hook) and this would
    -- overwrite the setWMName "LG3D" and some Java apps will not work.
    $ withUrgencyHook myDzenUrgencyConfig
    $ def { modMask = modM hostname
          , terminal = term
          , borderWidth = 1
          , normalBorderColor  = "#545454"
          , focusedBorderColor = "#A00000"
          , logHook = myLogHook dzenStatusFile
          , manageHook = myManageHook
          , keys = \c -> mkKeymap c $ myKeys c hostname
          , mouseBindings = \c -> M.union (M.fromList $ myMouse (modM hostname) c) $ mouseBindings def c
          , layoutHook = myLayout
          , workspaces = topics
          , handleEventHook = myEventHook
          , startupHook = myStartupHook
          }

--}}}

--{{{ TopicSpaces

topics :: [Topic]
topics = [ "web", "mail", "irc", "im", "video", "music"
         , "spline", "usdx", "partdb", "riot", "zedat"
         , "emacs", "xmonad", "gimp", "misc"]

topicsConfig = TopicConfig
  { topicDirs = M.fromList $
                [ ("web", "./")
                , ("mail", "./")
                , ("irc", "./")
                , ("im", "./")
                , ("video", "media/video")
                , ("music", "media/audio/")
                , ("spline", "dev/spline/")
                , ("usdx", "dev/usdx/")
                , ("partdb", "dev/Part-DB/")
                , ("riot", "dev/RIOT/")
                , ("zedat", "./")
                , ("emacs", "./")
                , ("xmonad", ".xmonad/")
                , ("gimp", "./")
                ]
  , defaultTopicAction = const $ spawnShell >*> 2
  , defaultTopic = "web"
  , maxTopicHistory = 10
  , topicActions = M.fromList $
      [ ("web"    , spawnHere browser)
      , ("mail"   , spawn "emacsclient -e '(wl-start)'")
      , ("irc"    , spawnHere "hexchat")
      , ("im"     , spawnHere "tkabber")
      , ("video"  , return ())
      , ("music"  , spawnHere "guayadeque")
      , ("zedat"  , spawnHere $ term ++ " -e is")
      , ("spline" , spawnHere $ term ++ " -e ssh fob")
      , ("emacs"  , spawnHere "emacs")
      , ("gimp"   , spawnHere "gimp")
      , ("misc"   , return ())
      ]
  }
  where
    spawnShell = currentTopicDir topicsConfig >>= spawnShellIn
    spawnShellIn dir =
      spawnHere $ "in-dir " ++ dir ++ " " ++ term

topicsGrid =
  withWindowSet $ \w -> do
    let wss          = filter (\w -> W.tag w /= "NSP") $ W.workspaces w
        topicMap     = map (\t -> (W.tag t, t)) wss
        newTopics    = filter (\used -> ((W.tag used) `notElem` topics)) wss
        sortedTopics = mapMaybe (\name -> lookup name topicMap) topics
    gridselect topicsGridConfig $ map (\t -> (W.tag t, t)) $ sortedTopics ++ newTopics

promptedGoto = do
  topic <- topicsGrid
  whenJust topic (switchTopic topicsConfig . W.tag)

promptedShift = do
  topic <- topicsGrid
  whenJust topic $ (\y -> windows (W.greedyView y . W.shift y)) . W.tag

--}}}

--{{{ Prompts

data MyShell = MyShell
instance XPrompt MyShell where
    showXPrompt MyShell   = "Run: "
myShellPrompt :: XPConfig -> X ()
myShellPrompt c = do
    cmds <- io getCommands
    mkXPrompt MyShell c (getShellCompl cmds) spawn

--}}}

--{{{ Scratchpads

scratchpads =
  [ NS "hotot" "hotot" (className =? "Hotot")
    (customFloating $ W.RationalRect 0.01 0.01 0.4 0.98)
  , NS "log" "urxvt -name logtail -e logtail" (appName =? "logtail")
    (customFloating $ W.RationalRect 0.03 0.03 0.94 0.6)
  ]

notNspHiddenWS :: X (WindowSpace -> Bool)
notNspHiddenWS = do notNsp <- notNspWS
                    hidden <- hiddenWS
                    nonEmpty <- nonEmptyWS
                    return (\w -> hidden w && nonEmpty w && notNsp w)
  where
    hiddenWS = do hs <- gets (map W.tag . W.hidden . windowset)
                  return (\w -> W.tag w `elem` hs)
    nonEmptyWS = return $ isJust . W.stack
    notNspWS = return $ ("NSP" /=) . W.tag


--}}}

--{{{ Themes

myPP statusFile = namedScratchpadFilterOutWorkspacePP $ def
        { ppCurrent = wrap "^fg(#FF0000) " " "
        , ppVisible = wrap "^fg(#0000FF) " " "
        , ppHiddenNoWindows = \_ -> ""
        , ppUrgent = wrap "^bg(#FFFF00)^fg(#FF0000) " " "
        , ppHidden = pad
        , ppWsSep = "^fg(#888)^bg(#000):"
        , ppSep = "^fg(#888)^bg(#000):"
        , ppLayout = wrap "^fg(#fff)" "^fg(#888)" . pad . (\x -> transformLayout x)
        , ppTitle = ("^fg(#FF0000) " ++) . dzenEscape
        , ppOrder = \(ws:l:t:[]) -> ["^fg(#888)^bg(#000)" ++ ws,l,t]
        , ppOutput = dzenWriteStatus statusFile
        }
  where
    dzenWriteStatus file status = do
      hPutStrLn file status
      hFlush file
    -- helper for better Layoutnames
    transformLayout x = foldl1 (++)
                        $ layoutTransform
                        $ magnifierTransform
                        $ [] : words x
    magnifierTransform (prefix:magnifier:status:xs)
      | magnifier == "Magnifier" && status == "(off)" = (prefix ++ "+"):xs
      | magnifier == "Magnifier" = (prefix ++ "*"):status:xs
      | otherwise =  ((prefix ++ unwords [magnifier, status]):xs)
    layoutTransform (prefix:l)
      | unwords l == "ThreeCol" = [prefix, "|||"]
      | unwords l == "Tabbed" = [prefix, "[ ]"]
      | unwords l == "Mirror Tall" = [prefix, "=|="]
      | unwords l == "Tall" = [prefix, "[]="]
      | otherwise = prefix:l

alexTheme :: Theme
alexTheme = def
        { inactiveBorderColor = "#545454"
        , activeBorderColor = "#6E0000"
        , activeColor = "#6E0000"
        , inactiveColor = "#424242"
        , inactiveTextColor = "#ffffff"
        , activeTextColor = "#ffffff"
        , fontName = font
        , decoHeight = 19
        }

alexXPConfig :: XPConfig
alexXPConfig = def
        { P.font = font
        , P.height = 20
        }

historyGridConfig :: GSConfig String
historyGridConfig = def
        { gs_cellheight = 50
        , gs_cellwidth = 300
        , gs_navigate = navNSearch
        , gs_font = font
        }

topicsColorizer :: W.Workspace tag layout stack -> Bool -> X (String, String)
topicsColorizer topic selected
  | empty && selected = return ("#f4f6f6", "#002b36")
  | selected = return ("#839596", "#002b36")
  | empty = return ("#001014", "#839496")
  | otherwise = return ("#002b36", "#ffffff")
  where
    empty = null $ W.integrate' $ W.stack topic

topicsGridConfig :: GSConfig (W.Workspace tag layout stack)
topicsGridConfig = def
        { gs_navigate = navNSearch
        , gs_font = font
        , gs_colorizer = topicsColorizer
        }

confirmConfig :: GSConfig Bool
confirmConfig = def
        { gs_cellheight = 150
        , gs_cellwidth = 300
        , gs_cellpadding = 50
        , gs_font = "xft:Droid Sans Mono Slashed Bold-35"
        , gs_originFractX = (1/2)
        , gs_originFractY = (1/3)
        }

confirm :: String -> X() -> X()
confirm = Confirm.confirm confirmConfig

--}}}

--{{{ Hooks

myLogHook statusFile = do
  ewmhDesktopsLogHook
  topicOutput <- lastTopics
  otherOutput <- dynamicLogString ppWithoutTopics
  io $ ppOutput pp (topicOutput ++ otherOutput)
  where
    pp                     = myPP statusFile
    ppWithDepth ws         = pp { ppHidden  = addDepth ws ppHidden
                                , ppVisible = addDepth ws ppVisible
                                , ppUrgent  = addDepth ws ppUrgent
                                }
    ppWithoutTopics        = pp { ppVisible = \_ -> ""
                                , ppCurrent = \_ -> ""
                                , ppUrgent  = \_ -> ""
                                , ppHidden  = \_ -> ""
                                }

    isEmpty                = isNothing . W.stack
    emptyTopics winset     = map W.tag $ filter isEmpty $ W.workspaces winset
    isVisible winset topic = topic /= "NSP" && (notElem topic $ emptyTopics winset)

    topicWithDepth topic   = ((topic ++ ":") ++) . show
    getDepth ws topic      = fromJust $ elemIndex topic $ ws ++ [topic]
    addDepth ws proj topic = proj pp $ topicWithDepth topic $ getDepth ws topic
    sortTopics ws          = take (maxTopicHistory topicsConfig) .
                             sortBy (comparing $ (getDepth ws) . W.tag) .
                             namedScratchpadFilterOutWorkspace

    lastTopics = do
      winset <- gets windowset
      urgents <- readUrgents
      setLastFocusedTopic (W.tag . W.workspace . W.current $ winset) (isVisible winset)
      lastWs <- getLastFocusedTopics
      return $ pprWindowSet (sortTopics lastWs) urgents (ppWithDepth lastWs) winset


myEventHook = do
  ewmhDesktopsEventHook
  serverModeEventHook
  focusOnMouseMove
  docksEventHook

myStartupHook = do
  ewmhDesktopsStartup
  adjustEventInput
  setWMName "LG3D"

myManageHook =
  namedScratchpadManageHook scratchpads
  <+> manageSpawn
  <+> xPropManageHook xPropMatches
  <+> manageDocks
  <+> (isDialog
       --> doCenterFloat)

  <+> (appName =? "hexcalc" -->
       (doRectFloat $ W.RationalRect 0.75 0.505 0.2 0.395))
  <+> (appName =? "xcalc" -->
       (doRectFloat $ W.RationalRect 0.75 0.1 0.2 0.395))
  <+> (appName =? "wpa_gui" -->
       (doRectFloat $ W.RationalRect 0.01 0.01 0.4 0.25))
  <+> (className =? "Vncviewer" -->
       doCenterFloat)

  -- (yt) flash fullscreen mode
  <+> (className =? "Operapluginwrapper-native" -->
       doFullFloat)
  <+> (className =? "Exe" -->
       doFullFloat)

  -- xcalendar
  <+> (appName =? "dayEditor" -->
       (doRectFloat $ W.RationalRect 0.5 0.02 0.33 0.3))
  <+> (appName =? "xcalendar" -->
       (doRectFloat $ W.RationalRect 0.83 0.02 0.15 0.3))

  -- emacs compose mail
  <+> (appName =? "wanderlust-draft" -->
       (doRectFloat $ W.RationalRect 0.1 0.1 0.8 0.8))

  <+> (className =? "Gxmessage" -->
       doCenterFloat)

xPropMatches :: [XPropMatch]
xPropMatches =
  [ (match, pmP $ W.shift target) | (target, match) <- shifts] ++
  [ (match, pmX $ float) | match <- floats]
  where
    floats = [ [(wM_CLASS, anyOf ["vlc", "Xmessage", "XVkbd", "Xdialog",
                                 "Pinentry", "Pinentry-gtk-2", "Tiemu",
                                 "ultrastardx", "Ediff", "xtensoftphone",
                                 "Pqiv", "XNots", "TeamViewer.exe",
                                 "AmsnWebcam"])]
             , [(wM_NAME, anyOf ["glxgears", "Passphrase Required",
                                "Mark all as read", "Xplanet 1.2.0",
                                "Eclipse"])]
             ]

    shifts = [ ("web",   [(wM_CLASS, anyOf ["Opera", "Chrome", "Google-chrome", "Chromium-browser",
                                            "Firefox-bin"])])
             , ("mail",  [(wM_CLASS, anyOf ["Claws-mail", "Evolution", "Mitter", "wanderlust"])])
             , ("mail",  [(wM_NAME,  anyOf ["newsbeuter"])])
             , ("irc",   [(wM_CLASS, anyOf ["Hexchat"])])
             , ("im",    [(wM_CLASS, anyOf ["TKabber", "headlines", "Vacuum"])])

               -- tkabber single messages
             , ("im",    [(wM_CLASS, anyOf' isPrefixOf ["chat_##xmpp##1_zedatconferencejabberfuberlinde",
                                                        "chat_##xmpp##1_mailanimuxdeSyslogBot"])])

             , ("code",  [(wM_CLASS, anyOf ["emacs"])])

             , ("video", [(wM_CLASS, anyOf ["MPlayer"])])
             , ("music", [(wM_CLASS, anyOf ["Amarokapp"])])
             ]

    anyOf' op valids tests = any (\test -> any (\valid -> op valid test) valids) tests
    anyOf                  = anyOf' (==)

--}}}

--{{{ Keys

myKeys c hostname =
  -- this line is critical to reload config - DON'T REMOVE
  [ ("M-q", broadcastMessage ReleaseResources >> restart "xmonad" True)
  , (shutdownKey, confirm "Logout?" $ io (exitWith ExitSuccess))

  , ("M-S-<Return>", spawn term)
  , ("M-<Return>", openLastHistoryGrid historyGridConfig 30)

    -- kill current, kill all
  , ("M-S-c", kill1)
  , ("M-C-c", kill)

    -- sticky
  , ("M-S-v", windows copyToAll)
  , ("M-C-v", killAllOtherCopies)

  , ("M-<Space>", sendMessage NextLayout)
  , ("M-S-<Space>", setLayout $ XMonad.layoutHook c)

  , ("M-<Tab>", windows W.focusDown)
  , ("M-S-<Tab>", windows W.focusUp)
  , ("M-j", windows W.focusDown)
  , ("M-k", windows W.focusUp)

  , ("M-S-j", windows W.swapDown)
  , ("M-S-k", windows W.swapUp)

  , ("M-m", selectWorkspace alexXPConfig)
  , ("M-S-m", withWorkspace alexXPConfig (windows . W.shift))
  , ("M-S-<Backspace>", removeWorkspace)

  , ("M-h", sendMessage Shrink)
  , ("M-l", sendMessage Expand)

    -- sink / sinkAll
  , ("M-t", withFocused $ windows . W.sink)
  , ("M-S-t", sinkAll)

  , ("M-z", namedScratchpadAction scratchpads "hotot")
  , ("M5-l", namedScratchpadAction scratchpads "log")

  , ("M-,", sendMessage (IncMasterN 1))
  , ("M-.", sendMessage (IncMasterN (-1)))

  , ("M-b", sendMessage ToggleStruts)

  , ("M-i", spawn "xprop | gxmessage -file -")

  , ("M-<Left>", moveTo Prev $ WSIs notNspHiddenWS)
  , ("M-<Right>", moveTo Next $ WSIs notNspHiddenWS)

  , ("M-d", spawn "fbsetroot -solid black")
  , ("M-f", spawn "fbsetbg -l")

  , ("M-^", focusUrgent)

  , ("M-p", myShellPrompt alexXPConfig)
  , ("M-e", launchApp alexXPConfig "emacsclient" >> (windows (W.greedyView "5:code")))

  , ("M-o M-k", passPrompt alexXPConfig)
  , ("M-o M-S-k", passGeneratePrompt alexXPConfig)
  , ("M-o M-m", manPrompt alexXPConfig)
  , ("M-o M-b", safePrompt browser alexXPConfig)
  , ("M-o M-s", sshPrompt alexXPConfig)
  , ("M-o M-x", xmonadPrompt alexXPConfig)

  , ("M-+", sendMessage Mag.MagnifyMore)
  , ("M-S-+", sendMessage Mag.MagnifyLess)
  , ("M-#", sendMessage Mag.Toggle)

    -- topics
  ,("M-s"  , promptedGoto)
  ,("M-S-s", promptedShift)
  ,("M-a"  , currentTopicAction  topicsConfig)

    -- multimedia keys
  , ("<XF86AudioLowerVolume>", spawn "amixer -c0 -- set Master playback 2dB-")
  , ("<XF86AudioRaiseVolume>", spawn "amixer -c0 -- set Master playback 2dB+")
  , ("<XF86AudioMute>", spawn "amixer -q -c0 set Master toggle")

    -- Screenshot
  , ("<Print>", spawn "scrot '%Y-%m-%d_%s_$wx$h.png' -e 'mv $f ~/images/screenshot/; pqiv ~/images/screenshot/$n'")

  ]
  ++
  [
    -- switch to / move to topic
    ("M-" ++ m ++ [k], a i)
      | (a, m) <- [(switchNthLastFocused topicsConfig,""), (shiftNthLastFocused, "S-")]
      , (i, k) <- zip [1..] "123456789"
  ]
  where
    shutdownKey = case hostname of
       "Australien" -> "M-S-q"
       _            -> "M-M5-q"

    -- Like X.A.TopicSpace.switchNthLastFocused but defaults to do nothing
    -- if depth is too big and not to switch to the default topic.
    switchNthLastFocused :: TopicConfig -> Int -> X ()
    switchNthLastFocused tg depth = do
      ws <- fmap (listToMaybe . drop depth) getLastFocusedTopics
      whenJust ws $ switchTopic tg

myMouse modm c =
  [ ((modm, button1),
     (\w -> focus w >> mouseMoveWindow w >> snapMagicMove (Just 50) (Just 50) w))

  , ((modm .|. shiftMask, button1),
     (\w -> focus w >> mouseMoveWindow w >> snapMagicMouseResize 0.8 (Just 50) (Just 50) w))

  , ((modm, button3),
     (\w -> focus w >> Flex.mouseWindow Flex.resize w))
  ]

--}}}

--{{{ Layout

myLayout =
  avoidStruts
  $ smartBorders
  $ Mag.magnifierOff
  $ trackFloating

  $ onWorkspace "mail" layoutsTabbed
  $ onWorkspace "im"  (imgrid ||| imtab ||| immosaic)
  $ onWorkspace "emacs" layoutsTabbed
  $ onWorkspace "video" (noBorders myTabbed)
  $ onWorkspace "gimp" gimp
  $ layouts
  where
    layouts  = tiled ||| Mirror tiled ||| ThreeColMid 1 (3/100) (1/2) ||| myTabbed
    layoutsTabbed = myTabbed ||| tiled ||| Mirror tiled ||| ThreeColMid 1 (3/100) (1/2)
    tiled    = Tall 1 (3/100) (1/2)
    gimp     = named "gimp"
               $ withIM (0.11) (Role "gimp-toolbox")
               $ reflectHoriz
               $ withIM (0.15) (Role "gimp-dock") (trackFloating myTabbed)
    imbase a = withIM (1%7) (Or (Or (ClassName "Tkabber") (Role "roster"))
                             (And (ClassName "Vacuum") (Role "MainWindow"))) a
    imgrid   = imbase Grid
    imtab    = imbase myTabbed
    immosaic = imbase $ MosaicAlt M.empty
    myTabbed = named "Tabbed"
               $ tabbedBottom shrinkText alexTheme

--}}}