stockholm/lass/5pkgs/xmonad-lass/Main.hs

204 lines
7.3 KiB
Haskell
Raw Normal View History

2015-11-13 00:07:54 +00:00
{-# LANGUAGE DeriveDataTypeable #-} -- for XS
{-# LANGUAGE FlexibleContexts #-} -- for xmonad'
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Control.Exception
import Text.Read (readEither)
import XMonad
import System.IO (hPutStrLn, stderr)
import System.Environment (getArgs, withArgs, getEnv, getEnvironment)
import System.Posix.Process (executeFile)
import XMonad.Prompt (defaultXPConfig)
import XMonad.Actions.DynamicWorkspaces ( addWorkspacePrompt, renameWorkspace
, removeEmptyWorkspace)
import XMonad.Actions.GridSelect
import XMonad.Actions.CycleWS (toggleWS)
--import XMonad.Actions.CopyWindow ( copy )
import XMonad.Layout.NoBorders ( smartBorders )
import qualified XMonad.StackSet as W
import Data.Map (Map)
import qualified Data.Map as Map
-- TODO import XMonad.Layout.WorkspaceDir
import XMonad.Hooks.UrgencyHook (SpawnUrgencyHook(..), withUrgencyHook)
-- import XMonad.Layout.Tabbed
--import XMonad.Layout.MouseResizableTile
import XMonad.Layout.Reflect (reflectVert)
import XMonad.Layout.FixedColumn (FixedColumn(..))
import XMonad.Hooks.Place (placeHook, smart)
import XMonad.Hooks.FloatNext (floatNextHook)
import XMonad.Actions.PerWorkspaceKeys (chooseAction)
import XMonad.Layout.PerWorkspace (onWorkspace)
--import XMonad.Layout.BinarySpacePartition
import XMonad.Util.EZConfig (additionalKeysP)
import XMonad.Prompt (autoComplete, defaultXPConfig, XPConfig, mkXPrompt)
import XMonad.Hooks.UrgencyHook (focusUrgent, withUrgencyHook, urgencyBorderColor, BorderUrgencyHook(BorderUrgencyHook))
import XMonad.Actions.DynamicWorkspaces (addWorkspacePrompt, removeEmptyWorkspace, renameWorkspace, withWorkspace)
import XMonad.Hooks.FloatNext (floatNext, floatNextHook)
import XMonad.Prompt.Workspace
import XMonad.Actions.CopyWindow (copy, kill1)
import qualified Data.Map as M
import XMonad.Hooks.ManageDocks (avoidStruts, manageDocks, ToggleStruts(ToggleStruts))
--import XMonad.Actions.Submap
import XMonad.Stockholm.Pager
import XMonad.Stockholm.Rhombus
import XMonad.Stockholm.Shutdown
2015-11-13 00:07:54 +00:00
myTerm :: String
myTerm = "urxvtc"
myRootTerm :: String
myRootTerm = "urxvtc -name root-urxvt -e su -"
myFont :: String
myFont = "-schumacher-*-*-*-*-*-*-*-*-*-*-*-iso10646-*"
main :: IO ()
main = getArgs >>= \case
["--shutdown"] -> sendShutdownEvent
_ -> mainNoArgs
mainNoArgs :: IO ()
mainNoArgs = do
workspaces0 <- getWorkspaces0
2015-11-13 00:07:54 +00:00
xmonad'
-- $ withUrgencyHookC dzenUrgencyHook { args = ["-bg", "magenta", "-fg", "magenta", "-h", "2"], duration = 500000 }
-- urgencyConfig { remindWhen = Every 1 }
-- $ withUrgencyHook borderUrgencyHook "magenta"
-- $ withUrgencyHookC BorderUrgencyHook { urgencyBorderColor = "magenta" } urgencyConfig { suppressWhen = Never }
$ withUrgencyHook (SpawnUrgencyHook "echo emit Urgency ")
$ defaultConfig
{ terminal = myTerm
, modMask = mod4Mask
, workspaces = workspaces0
2015-11-13 00:07:54 +00:00
, layoutHook = smartBorders $ myLayoutHook
-- , handleEventHook = myHandleEventHooks <+> handleTimerEvent
--, handleEventHook = handleTimerEvent
, manageHook = placeHook (smart (1,0)) <+> floatNextHook
, startupHook = spawn "echo emit XMonadStartup"
, normalBorderColor = "#1c1c1c"
, focusedBorderColor = "#f000b0"
, handleEventHook = handleShutdownEvent
} `additionalKeysP` myKeyMap
myLayoutHook = defLayout
where
defLayout = (avoidStruts $ Tall 1 (3/100) (1/2) ||| Full ||| Mirror (Tall 1 (3/100) (1/2))) ||| FixedColumn 2 80 80 1
xmonad' :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
xmonad' conf = do
path <- getEnv "XMONAD_STATE"
try (readFile path) >>= \case
Right content -> do
hPutStrLn stderr ("resuming from " ++ path)
withArgs ("--resume" : lines content) (xmonad conf)
Left e -> do
hPutStrLn stderr (displaySomeException e)
xmonad conf
getWorkspaces0 :: IO [String]
getWorkspaces0 =
try (getEnv "XMONAD_WORKSPACES0_FILE") >>= \case
Left e -> warn (displaySomeException e)
Right p -> try (readFile p) >>= \case
Left e -> warn (displaySomeException e)
Right x -> case readEither x of
Left e -> warn e
Right y -> return y
where
warn msg = hPutStrLn stderr ("getWorkspaces0: " ++ msg) >> return []
2015-11-13 00:07:54 +00:00
displaySomeException :: SomeException -> String
displaySomeException = displayException
myKeyMap =
[ ("M4-<F11>", spawn "/var/setuid-wrappers/slock")
2015-11-13 00:07:54 +00:00
, ("M4-p", spawn "passmenu --type")
--, ("M4-r", spawn "exe=$(yeganesh -x) && eval \"exec $exe\"")
2015-11-13 00:07:54 +00:00
, ("<XF86AudioRaiseVolume>", spawn "pactl -- set-sink-volume 0 +4%")
, ("<XF86AudioLowerVolume>", spawn "pactl -- set-sink-volume 0 -4%")
, ("<XF86Launch1>", gridselectWorkspace myWSConfig W.view)
, ("M4-a", focusUrgent)
, ("M4-S-r", renameWorkspace defaultXPConfig)
, ("M4-S-a", addWorkspacePrompt defaultXPConfig)
, ("M4-S-<Backspace>", removeEmptyWorkspace)
, ("M4-S-c", kill1)
, ("M4-<Esc>", toggleWS)
, ("M4-S-<Enter>", spawn myTerm)
, ("M4-x", floatNext True >> spawn myTerm)
, ("M4-f", floatNext True)
, ("M4-b", sendMessage ToggleStruts)
, ("M4-v", withWorkspace myXPConfig (windows . W.view))
, ("M4-S-v", withWorkspace myXPConfig (windows . W.shift))
, ("M4-C-v", withWorkspace myXPConfig (windows . copy))
-- , (_4 , xK_q ) & \k -> (k, goToSelected myCNConfig { gs_navigate = makeGSNav k } )
-- , (_4S, xK_q ) & \k -> (k, bringSelected myCNConfig { gs_navigate = makeGSNav k } )
-- , (_4C, xK_q ) & \k -> (k, withSelectedWindow ( \a -> get >>= \s -> put s { windowset = copyWindow a (W.tag $ W.workspace $ W.current $ windowset s) (windowset s) } ) myCNConfig { gs_navigate = makeGSNav k } )
--, ("M4-<F1>", perWorkspaceAction workspaceConfigs)
, ("M4-S-q", return ())
]
myGSConfig = defaultGSConfig
{ gs_cellheight = 50
, gs_cellpadding = 2
, gs_navigate = navNSearch
, gs_font = myFont
}
myXPConfig :: XPConfig
myXPConfig = defaultXPConfig
{ autoComplete = Just 5000
}
myWSConfig = myGSConfig
{ gs_cellwidth = 50
}
pagerConfig :: PagerConfig
pagerConfig = defaultPagerConfig
{ pc_font = myFont
, pc_cellwidth = 64
--, pc_cellheight = 36 -- TODO automatically keep screen aspect
--, pc_borderwidth = 1
--, pc_matchcolor = "#f0b000"
, pc_matchmethod = MatchPrefix
--, pc_colors = pagerWorkspaceColors
, pc_windowColors = windowColors
}
where
windowColors _ _ _ True _ = ("#ef4242","#ff2323")
windowColors wsf m c u wf = do
let def = defaultWindowColors wsf m c u wf
if m == False && wf == True
then ("#402020", snd def)
else def
wGSConfig :: GSConfig Window
wGSConfig = defaultGSConfig
{ gs_cellheight = 20
, gs_cellwidth = 192
, gs_cellpadding = 5
, gs_font = myFont
, gs_navigate = navNSearch
}
(&) :: a -> (a -> c) -> c
(&) = flip ($)
allWorkspaceNames :: W.StackSet i l a sid sd -> X [i]
allWorkspaceNames ws =
return $ map W.tag (W.hidden ws) ++ [W.tag $ W.workspace $ W.current ws]