Initial commit

This commit is contained in:
Mats Rauhala 2019-03-19 10:10:18 +02:00
commit 3b117c4fe0
22 changed files with 811 additions and 0 deletions

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
dist/

5
ChangeLog.md Normal file
View File

@ -0,0 +1,5 @@
# Revision history for xmonad-masser
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.

30
LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright (c) 2019, Mats Rauhala
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Mats Rauhala nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

3
default.nix Normal file
View File

@ -0,0 +1,3 @@
{ haskellPackages }:
haskellPackages.callCabal2nix "xmonad-masser" ./. {}

15
release.nix Normal file
View File

@ -0,0 +1,15 @@
{ nixpkgs ? import <nixpkgs> {} }:
rec {
xmonad-masser = nixpkgs.callPackage ./default.nix {};
shell = nixpkgs.buildEnv {
name = "shell";
paths = [];
buildInputs = with nixpkgs.haskellPackages; [
(ghcWithPackages (_: xmonad-masser.buildInputs ++ xmonad-masser.propagatedBuildInputs))
ghcid
cabal-install
nixpkgs.pkgs.binutils
];
};
}

3
shell.nix Normal file
View File

@ -0,0 +1,3 @@
{ nixpkgs ? import <nixpkgs> {} }:
(nixpkgs.callPackage ./release.nix {}).shell

36
src/XMonad/Config.hs Normal file
View File

@ -0,0 +1,36 @@
{-# Language RecordWildCards #-}
{-# Language DeriveGeneric #-}
{-# Language OverloadedStrings #-}
module Config where
import Dhall
data Applications = Applications { urxvt :: Text
, prompt :: Text
, browser :: Text
, launcher :: Text -- xdg-open
, screenshot :: Text
}
deriving (Show, Generic)
data TopicRule = TopicRule { topicName :: Text
, topicHome :: Maybe Text
, topicAction :: Maybe Text }
deriving (Show, Generic)
data ExtraConfig = ExtraConfig { applications :: Applications
, topics :: [TopicRule]}
deriving (Show, Generic)
defaultExtraConfig :: ExtraConfig
defaultExtraConfig =
let applications = Applications{..}
urxvt = "urxvt"
prompt = "xmobar"
browser = "qutebrowser"
launcher = "xdg-open"
screenshot = "scrot ~/screenSel.png"
topics = []
in ExtraConfig{..}
instance Interpret ExtraConfig
instance Interpret TopicRule
instance Interpret Applications

265
src/XMonad/Config/MasseR.hs Normal file
View File

@ -0,0 +1,265 @@
{-# LANGUAGE OverloadedStrings #-}
module XMonad.Config.MasseR where
import XMonad.Password
import XMonad.CustomPrompt
import XMonad.TopicSpace
import qualified Data.List as List
import XMonad
import XMonad.Actions.CycleWS (swapNextScreen)
import XMonad.Actions.Search
import XMonad.Hooks.EwmhDesktops (ewmh, ewmhDesktopsStartup)
import XMonad.Hooks.SetWMName (setWMName)
import XMonad.Hooks.UrgencyHook (args, dzenUrgencyHook,
withUrgencyHook)
import XMonad.Layout.Accordion
import XMonad.Layout.BinarySpacePartition (emptyBSP)
import XMonad.Layout.Decoration (Decoration,
DefaultShrinker)
import XMonad.Layout.DwmStyle
import XMonad.Layout.HintedGrid
import XMonad.Layout.LayoutModifier (ModifiedLayout)
import XMonad.Layout.Master
import XMonad.Layout.NoBorders (smartBorders)
import XMonad.Layout.PerWorkspace (onWorkspace)
import XMonad.Layout.Renamed
import XMonad.Layout.Simplest (Simplest)
import XMonad.Layout.Spiral
import XMonad.Layout.Tabbed (TabbedDecoration,
Theme (..), shrinkText,
tabbed)
import XMonad.Layout.ToggleLayouts (ToggleLayout (..))
import XMonad.Prompt.RunOrRaise (runOrRaisePrompt)
import qualified XMonad.StackSet as W
import XMonad.Util.EZConfig
import XMonad.XMobar (zenburnPP)
import Data.Monoid (Endo, (<>))
import XMonad.Util.NamedScratchpad
import XMonad.Util.SpawnOnce
import System.IO (hClose, hPutStr)
import XMonad.Actions.Navigation2D
import XMonad.Util.NamedActions
import XMonad.Util.Run (spawnPipe)
import XMonad.Config.MasseR.ExtraConfig
-- import Customizations
import qualified Data.Text as T
import XMonad.Hooks.DynamicLog (statusBar)
import qualified Data.Set as S
spotify :: XConfig l -> NamedAction
spotify conf = submapName . mkNamedKeymap conf $
[ ("M-p", addName "Play" $ spawn "sp play") ]
scratchpads :: [NamedScratchpad]
scratchpads = [
NS "notes" "vim -g --role notes -c 'e ~/wikidata/index.md'" (wmRole =? "notes") nonFloating
]
where wmRole = stringProperty "WM_WINDOW_ROLE"
scratchSubmaps :: XConfig l -> NamedAction
scratchSubmaps conf = submapName . mkNamedKeymap conf $ [
("M-n", addName "Open notes" $ namedScratchpadAction scratchpads "notes")
]
-- Search engines inside submaps
searchSubmaps :: XConfig l -> NamedAction
searchSubmaps conf =
let mkBrowser = promptSearchBrowser def "qutebrowser"
_googleP = addName "Search google" $ mkBrowser google
ddgP = addName "Search duckduckgo" $ mkBrowser (searchEngine "duckduckgo" "http://duckduckgo.com/?q=")
in submapName . mkNamedKeymap conf $
[ ("d", ddgP) -- Training to use ddg again
, ("g", ddgP) -- training to use ddg again
]
myNav2d :: Navigation2DConfig
myNav2d = def { defaultTiledNavigation = lineNavigation }
showKeybindings :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
showKeybindings x = addName "Show keybindings" $ io $ do
h <- spawnPipe "zenity --text-info --font=terminus"
hPutStr h (unlines $ showKm x)
hClose h
-- Layout
myTabConfig :: Theme
myTabConfig = def {
activeBorderColor = "#DCDCCC"
, activeTextColor = "#DCDCCC"
, activeColor = "#3F3F3F"
, fontName = "xft:Inconsolata-9"
, inactiveBorderColor = "#262626"
, inactiveTextColor = "#9FAFAF"
, inactiveColor = "#262626"
}
(=~?) :: XMonad.Query String -> String -> XMonad.Query Bool
q =~? x = fmap (x `List.isInfixOf`) q
-- Manage hooks
-- Move programs to their workspaces
myManageHook :: XMonad.Query (Endo WindowSet)
myManageHook = composeAll $ concat [
dynamicsHook
, webHooks
, pdfHooks
, documentHooks
, floatHooks
, debuggerHooks
, ideHooks
, flowHook
]
where
classHook y = map (\x -> className =? x --> y)
ideHooks = classHook (doShift "eclipse") [
"Anypoint Studio"
]
webHooks = classHook (doShift "web") [
"Firefox"
, "qutebrowser"
, "Midori"
, "chromium-browser"
, "Uzbl-tabbed"
, "Uzbl-core"
]
pdfHooks = classHook (doShift "pdf") [
"Evince"
, "Okular"
, "Kpdf"
, "Xdvi"
, ".zathura-wrapped_"
]
documentHooks = classHook (doShift "documents") [
"libreoffice"
, "libreoffice-calc"
, "Assistant"
, "Bouml"
]
floatHooks = classHook doFloat [
"SMplayer"
, "Gimp"
, "MPlayer"
, "Kaffeine"
, "Xmessage"
, "Wfica_Seamless"
, "mpv"
]
debuggerHooks = classHook (doShift "debugger") [
"JSwat Debugger",
"DBeaver"
]
dynamicsHook = [title =~? "Dynamics" --> doShift "dynamics"]
flowHook = [title =~? "www.flowdock.com" --> doShift "flowdock"]
myKeys :: ExtraConfig -> XConfig l -> [((KeyMask, KeySym), NamedAction)]
myKeys extraConfig conf =
let subKeys str ks = subtitle str : mkNamedKeymap conf ks in
subKeys "Actions" [ ("M-S-r", addName "foo" $ spawn "xmonad --restart")
, ("M-C-l", addName "Lock screen" $ spawn locker)] ^++^
subKeys "System" [ ("<XF86Sleep>", addName "Suspend machine" $ spawn "sudo pm-suspend")
, ("<XF86AudioRaiseVolume>", addName "Increase volume" $ spawn "amixer set Master 2%+")
, ("<XF86AudioLowerVolume>", addName "Decrease volume" $ spawn "amixer set Master 2%-")
, ("M-<plus>", addName "Increase volume" $ spawn "amixer set Master 2+")
, ("M-<minus>", addName "Decrease volume" $ spawn "amixer set Master 2-")
-- , ("<XF86AudioPlay>", addName "Play/pause spotify" $ spawn "/home/masse/.local/bin/sp play")
, ("<XF86AudioPlay>", addName "Play/pause mopidy" $ spawn "mpc toggle")
, ("M-m", spotify conf)
, ("M-S-<Space>", addName "Swap screens" swapNextScreen)
, ("M-<Backspace>", addName "Kill window" kill)
-- scrot requires `unGrab`
, ("M-<Print>", addName "Take screenshot" $ spawn (screenshot . applications $ extraConfig))] ^++^
subKeys "Launchers" [ ("M-S-y", addName "Open youtube" $ spawn "mpv $(clip -o)")
, ("M-S-<Return>", addName "Open terminal" $ spawn $ XMonad.terminal conf)
, ("M-n", scratchSubmaps conf)
, ("M-s", searchSubmaps conf)
, ("M-p", addName "Retrieve password" $ passPrompt def)
, ("M-S-e", addName "Open with app" xdg_open)
, ("M-e", addName "Run app" $ runOrRaisePrompt def)] ^++^
subKeys "Windows" [ ("M-j", addName "Go down" $ windowGo D False)
, ("M-k", addName "Go up" $ windowGo U False)
, ("M-h", addName "Go left" $ windowGo L False)
, ("M-l", addName "Go right" $ windowGo R False)
, ("M-S-j", addName "Shift window down" $ windowSwap D False)
, ("M-S-k", addName "Shift window up" $ windowSwap U False)
, ("M-S-h", addName "Shift window left" $ windowSwap L False)
, ("M-S-l", addName "Shift window right" $ windowSwap R False)
, ("M-.", addName "Go to previous window" $ windows W.focusDown)
, ("M-,", addName "Go to next window" $ windows W.focusUp)
, ("M-S-m", addName "Swap master" $ windows W.swapMaster)
] ^++^
subKeys "Projects & Workspaces" (topicKeys' extraConfig conf) ^++^
subKeys "Layout management" [ ("M-C-<Space>", addName "Toggle layout" $ sendMessage ToggleLayout)
, ("M-<Space>", addName "Next layout" $ sendMessage NextLayout)] ^++^
subKeys "Resize" []
where
locker = "sh ~/scripts/lock.sh"
myStartupHook :: X ()
myStartupHook = spawnOnce "$HOME/wminit"
masser :: ExtraConfig -> IO ()
masser extraConfig = xmonad =<< statusBar (bar extraConfig) zenburnPP toggleStrutsKey myConfig
where
toggleStrutsKey XConfig{modMask=modm} = (modm, xK_b)
bar = prompt . applications
myConfig = withUrgencyHook dzenUrgencyHook { args = ["-bg", "darkgreen", "-xs", "1"]} $
withNavigation2DConfig myNav2d $
ewmh $
addDescrKeys' ((mod4Mask, xK_F1), showKeybindings) (myKeys extraConfig) $
def {
modMask = mod4Mask -- Hyper
, terminal = urxvt . applications $ extraConfig
, keys = const mempty
, workspaces = let defaults = ["irc", "web", "mail"]
external = map (T.unpack . topicName) . topics $ extraConfig
in S.toList (S.fromList defaults <> S.fromList external)
, layoutHook = smartBorders myLayout
, clickJustFocuses = False
, startupHook = myStartupHook >> ewmhDesktopsStartup >> setWMName "LG3D"
, borderWidth = 2
, normalBorderColor = "#262626"
, focusedBorderColor = "#7F9F7F"
, manageHook = myManageHook
, focusFollowsMouse = False
}
myLayout = onWorkspace "web" webLayout $
onWorkspace "dynamics" webLayout $
onWorkspace "pdf" pdfLayout $
onWorkspace "documents" documentLayout $
onWorkspace "mail" mailLayout $
onWorkspace "irc" ircLayout
defLayout
where
-- Default layout
defLayout = tiled ||| tabLayout ||| readLayout ||| bspLayout ||| vimLayout ||| spiral (6/7) ||| Full
ircLayout = GridRatio (4/3) False ||| emptyBSP
-- Pdfs are restricted to tabs
vimLayout = Mirror (mastered (1/100) (4/5) Accordion)
pdfLayout = readLayout ||| tiled ||| tabLayout
readLayout = renamed [Replace "2/3"] (dwmStyle shrinkText myTabConfig (mastered (1/100) (2/3) Accordion))
bspLayout = renamed [Replace "master bsp"] (dwmStyle shrinkText myTabConfig (mastered (1/100) (2/3) (Mirror emptyBSP)))
-- Documents are by default tabs, but have looser restrictions
documentLayout = tabLayout ||| Full ||| tiled ||| Mirror tiled
-- Web is either tabbed, full, or tiled
webLayout = readLayout ||| tabLayout ||| Full ||| tiled
tiled = Tall nmaster delta ratio
-- I need to restrict the type or type inferencer can't deduce type classes
tabLayout :: ModifiedLayout (Decoration TabbedDecoration DefaultShrinker) Simplest Window
tabLayout = tabbed shrinkText myTabConfig
mailLayout = readLayout ||| tabLayout
delta = 3/100
ratio = 1/2
nmaster = 1

View File

@ -0,0 +1,14 @@
{-# LANGUAGE DeriveGeneric #-}
module XMonad.Config.MasseR.ExtraConfig where
import GHC.Generics (Generic)
import Data.Text (Text)
data Applications = Applications { browser :: FilePath, launcher :: FilePath, prompt :: FilePath, screenshot :: FilePath, urxvt :: FilePath } deriving (Show, Generic)
data TopicRule = TopicRule { topicName :: Text
, topicHome :: Maybe Text
, topicAction :: Maybe Text }
deriving (Show, Generic)
data ExtraConfig = ExtraConfig { applications :: Applications, topics :: [ TopicRule ] } deriving (Show, Generic)

View File

@ -0,0 +1,17 @@
module XMonad.Configurable (Configurable, EndoM(..), configure) where
import Control.Monad ((<=<))
import Control.Monad.Reader
newtype EndoM m a = EndoM { appEndoM :: a -> m a }
instance Monad m => Semigroup (EndoM m a) where
EndoM f <> EndoM g = EndoM (f <=< g)
instance Monad m => Monoid (EndoM m a) where
mempty = EndoM pure
type Configurable a = EndoM (Reader a) a
configure :: Configurable a -> a
configure (EndoM f) = fix (\self -> runReader (f self) self)

View File

@ -0,0 +1,14 @@
module XMonad.CustomPrompt (xdg_open, browser) where
import qualified XMonad.Prompt.AppLauncher as AL
import XMonad.Prompt
import XMonad (X)
launchApp :: AL.Application -> X ()
launchApp = AL.launchApp def
xdg_open :: X ()
xdg_open = launchApp "xdg-open"
browser :: X ()
browser = launchApp "qutebrowser"

View File

@ -0,0 +1,21 @@
{-# Language FlexibleContexts #-}
module Customizations (customizations) where
import Configurable
import XMonad
import XMonad.Util.EZConfig (additionalKeys)
import Customizations.Types
import qualified Customizations.Topics as Topics
import Control.Lens
customizations :: LayoutClass l Window => XConfig l -> XConfig l
customizations start = xconfig $ configure (mconcat [topics, Topics.customize, initial])
where
initial = EndoM $ \_ -> pure (Customize start def)
topics :: LayoutClass l Window => Configurable (Customize l)
topics = EndoM $ \super -> do
_self <- ask
pure (over _xconfig _ super)

57
src/XMonad/Password.hs Normal file
View File

@ -0,0 +1,57 @@
module XMonad.Password (passGeneratePrompt, passPrompt) where
import Control.Monad.Trans (liftIO)
import Data.Function (on)
import Data.List (foldl', scanl', sort, sortBy)
import System.Directory (getHomeDirectory)
import System.FilePath.Posix (dropExtension, takeExtension, (</>))
import System.Posix.Env (getEnv)
import XMonad.Core
import XMonad.Prompt
import XMonad.Util.Run (runProcessWithInput)
data Pass = Pass { passLabel :: String }
-- Rosetta code levenshtein
levenshtein :: String -> String -> Int
levenshtein s1 s2 = last $ foldl' transform [0..length s1] s2
where
transform [] _ = []
transform ns@(n:ns1) c = scanl' calc (n+1) $ zip3 s1 ns ns1
where
calc z (c1, x, y) = minimum [y+1, z+1, x + (fromEnum (c1 /= c) * 2)]
instance XPrompt Pass where
showXPrompt p = passLabel p <> ": "
commandToComplete _ = id
nextCompletion _ = getNextCompletion
passGeneratePrompt :: XPConfig -> X ()
passGeneratePrompt _ = return () -- Not implemented
passPrompt :: XPConfig -> X ()
passPrompt = mkPassPrompt "Select password" selectPassword
mkPassPrompt :: String -> (String -> X ()) -> XPConfig -> X ()
mkPassPrompt label f conf = do
-- I'm just sorting here, but could use some kind of fuzzy matching instead, but it requires a bit more effort
passwords <- sort <$> liftIO getPasswords
-- Other change, use infixof instead of prefixof
mkXPrompt (Pass label) conf (\input -> pure (sortBy (compare `on` (levenshtein input)) . filter (consumes input) $ passwords)) f
where
consumes [] _ = True -- everything consumed
consumes (_:_) [] = False -- all not consumed
consumes (a:xs) (a':ys) | a == a' = consumes xs ys
| otherwise = consumes (a:xs) ys
getStore = do
let storeDefault = (</> ".password-store")
maybe (storeDefault <$> getHomeDirectory) pure =<< getEnv "PASSWORD_STORE_DIR"
getPasswords = do
passwordStoreDir <- getStore
files <- runProcessWithInput "find" [ passwordStoreDir, "-type", "f", "-name", "*.gpg", "-printf", "%P\n"] []
return . map (\path -> if path `hasExtension` ".gpg" then dropExtension path else path) . lines $ files
hasExtension path ext = takeExtension path == ext
selectPassword :: String -> X ()
selectPassword pass = spawn $ "pass --clip " ++ pass

1
src/XMonad/Projects.hs Normal file
View File

@ -0,0 +1 @@
module Projects where

47
src/XMonad/RestartFile.hs Normal file
View File

@ -0,0 +1,47 @@
module RestartFile (restartFile, resumeArgsFromFile, getArgs, withArgs) where
import XMonad.Core
import XMonad.Operations
import qualified XMonad.StackSet as W
import Graphics.X11.Xlib.Event
import Control.Monad.Reader (asks)
import Control.Monad.State (gets)
import Data.Maybe
import Data.List (intercalate)
import qualified Data.Map.Strict as M
import System.Environment (getArgs, withArgs)
import Control.Monad
import Control.Exception
import System.Posix.Process (executeFile)
stateFile = "xmonadargs.txt"
restartFile :: String -> Bool -> X ()
restartFile prog resume = do
io $ appendFile "/home/masse/xmonad.log" $ "trying to restart"
broadcastMessage ReleaseResources
io . flush =<< asks display
let wsData = show . W.mapLayout show . windowset
maybeShow (t, Right (PersistentExtension ext)) = Just (t, show ext)
maybeShow (t, Left str) = Just (t, str)
maybeShow _ = Nothing
extState = return . show . mapMaybe maybeShow . M.toList . extensibleState
args <- if resume then return ["--resume"] else return []
when resume $ do
argsstr <- gets (\s -> intercalate "\n" ("--resume":wsData s:extState s))
catchIO $ writeFile stateFile argsstr
return ()
catchIO (executeFile prog True args Nothing)
catchAny :: IO a -> (SomeException -> IO a) -> IO a
catchAny = Control.Exception.catch
resumeArgsFromFile :: IO [String]
resumeArgsFromFile = do
let readLines = liftM lines . readFile $ stateFile
args <- getArgs
if ["--resume"] == args then
catchAny readLines $ \e -> do
appendFile "/home/masse/xmonad.log" $ "got error" ++ show e
return args
else return args

38
src/XMonad/Screen.hs Normal file
View File

@ -0,0 +1,38 @@
module Screen (screenWidth, nextScreen, prevScreen) where
import Graphics.X11.Xinerama (xineramaQueryScreens, XineramaScreenInfo(..))
import Graphics.X11.Xlib (openDisplay, closeDisplay)
import qualified XMonad.Actions.CycleWS as CycleWS
import XMonad (X())
import Control.Monad.Trans (liftIO)
screenWidth :: Int -> IO Int
screenWidth idx = do
dsp <- openDisplay "" -- I don't know what the string does :/
info <- xineramaQueryScreens dsp
case info of
Nothing -> return 0
Just [] -> return 0
Just screens -> if idx >= 0 && idx < length screens
then (return . fromIntegral . xsi_width) (screens !! idx)
else return 0
swapScreenDir :: IO Bool
swapScreenDir = do
dsp <- openDisplay ""
info <- xineramaQueryScreens dsp
closeDisplay dsp
case info of
Nothing -> return False
Just [] -> return False
Just (s:_) -> return (xsi_width s > 0)
nextScreen :: X ()
nextScreen = do
swap <- liftIO $ swapScreenDir -- Not too fond of querying the x each time we swap screens, but oh well
if swap then CycleWS.prevScreen else CycleWS.nextScreen
prevScreen :: X ()
prevScreen = do
swap <- liftIO $ swapScreenDir -- Not too fond of querying the x each time we swap screens, but oh well
if swap then CycleWS.nextScreen else CycleWS.prevScreen

59
src/XMonad/TopicSpace.hs Normal file
View File

@ -0,0 +1,59 @@
{-# Language RecordWildCards #-}
module XMonad.TopicSpace (topicKeys', addTopic, TopicAction(..)) where
import XMonad.Actions.TopicSpace
import XMonad
import qualified Data.Map as M
import XMonad.Actions.GridSelect
import XMonad.Actions.DynamicWorkspaces
import XMonad.TopicUtils
import XMonad.Util.EZConfig (mkNamedKeymap)
import XMonad.Util.NamedActions
import XMonad.Config.MasseR.ExtraConfig
import qualified Data.Text as T
import XMonad.Configurable
data TopicAction = TopicAction { name :: String
, action :: X ()
, home :: Maybe FilePath }
addTopic :: TopicAction -> Configurable TopicConfig
addTopic TopicAction{..} = EndoM $ \super -> let
newDirs = topicDirs super <> maybe mempty (M.singleton name) home
newActions = topicActions super <> M.singleton name action
in pure super { topicDirs = newDirs
, topicActions = newActions }
myTopicConfig :: ExtraConfig -> TopicConfig
myTopicConfig extraConfig =
let dirs = M.fromList [ (T.unpack n, T.unpack d) | TopicRule n (Just d) _ <- topics extraConfig ]
actions = M.fromList [ (T.unpack n, spawn (T.unpack a)) | TopicRule n _ (Just a) <- topics extraConfig ]
in def {
topicDirs = dirs
, defaultTopicAction = const (realTopicDir dirs >>= spawnShellIn)
, defaultTopic = "irc"
, topicActions = actions
}
topicKeys' :: ExtraConfig -> XConfig l -> [(String, NamedAction)]
topicKeys' extraConfig conf = [ ("M-y", addName "Change topic" $ visualSelect (myTopicConfig extraConfig))
, ("M-S-g", addName "Move window to topic" $ gridselectMove def)
, ("M-u", addName "Select window" $ gotoSelected' def{gs_colorizer = fromClassName})
, ("M-<Return>", addName "Open project action" $ currentTopicAction' (myTopicConfig extraConfig))
, ("M-w", modificationSubmaps' conf)]
spawnShellIn :: Dir -> X ()
spawnShellIn dir = safeRunInTerm dir Nothing
modificationSubmaps' :: XConfig l -> NamedAction
modificationSubmaps' conf =
submapName $ mkNamedKeymap conf [ ("a", addName "Add a new workspace" $ addWorkspacePrompt def)
, ("w", addName "Copy project" copyTopic)
, ("d", addName "Remove empty workspace" removeEmptyWorkspace)]

90
src/XMonad/TopicUtils.hs Normal file
View File

@ -0,0 +1,90 @@
module XMonad.TopicUtils where
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.List (isPrefixOf, sort, nub)
import XMonad.Actions.TopicSpace
import XMonad
import qualified Data.Map as M
import XMonad.Actions.GridSelect hiding (gridselectWorkspace)
import XMonad.Util.Run (safeSpawn)
import qualified XMonad.StackSet as W
import XMonad.Util.Dmenu (dmenu)
import XMonad.Actions.DynamicWorkspaces
import XMonad.Util.NamedWindows (getName)
realTopicDir :: M.Map String FilePath -> X String
realTopicDir tg = do
topic <- realTopic
return . fromMaybe "" . M.lookup topic $ tg
safeRunInTerm :: Dir -> Maybe String -> X ()
safeRunInTerm dir Nothing = safeSpawn "urxvt" ["-cd", dir]
safeRunInTerm dir (Just command) = safeSpawn "urxvt" ["-cd", dir, "-e", command]
inactiveTags :: X [WorkspaceId]
inactiveTags = map W.tag . inactive' <$> gets windowset
where
inactive' s = W.hidden s ++ map W.workspace (filter (\w -> (W.tag . W.workspace . W.current) s /= (W.tag . W.workspace) w) (W.visible s))
gridselectMove :: GSConfig WorkspaceId -> X ()
gridselectMove conf = do
topics <- inactiveTags
gridselect conf [(x,x) | x <- topics] >>= maybe (return ()) (windows . W.shift)
dmenuMove :: X ()
dmenuMove = do
topics <- inactiveTags
dmenu topics >>= \t -> windows (W.shift t)
gsConfig :: GSConfig Window
gsConfig = def{gs_navigate = navNSearch, gs_colorizer = fromClassName}
-- Copied from gridselect and modified so that it doesn't contain current and visible
-- - Doesn't contain current and visible
-- - Takes a topicspace viewfunc
gridselectWorkspace :: GSConfig WorkspaceId -> (WorkspaceId -> X ()) -> X ()
gridselectWorkspace conf viewFunc = withWindowSet $ \ws -> do
let wss = map W.tag . W.hidden $ ws
gridselect conf (zip wss wss) >>= flip whenJust viewFunc
gotoSelected' :: GSConfig Window -> X ()
gotoSelected' gsconf = do
w <- gridselectCurrentWindows gsconf
maybe (return ()) (windows . W.focusWindow) w
gridselectCurrentWindows :: GSConfig Window -> X (Maybe Window)
gridselectCurrentWindows gsconf = windowMap >>= gridselect gsconf
where
getName' = fmap show . getName
kvPair w = flip (,) w `fmap` getName' w
windowMap = do
ws <- gets (nub . W.integrate' . W.stack . W.workspace . W.current . windowset)
mapM kvPair ws
visualSelect :: TopicConfig -> X ()
visualSelect cfg = gridselectWorkspace def{gs_navigate = navNSearch, gs_colorizer = stringColorizer} (switchTopic cfg)
realTopic :: X String
realTopic = gets (real . W.tag . W.workspace . W.current . windowset)
where real = takeWhile (/= ':')
currentTopicAction' :: TopicConfig -> X ()
currentTopicAction' tg = do
topic <- realTopic
topicAction tg topic
copyTopic :: X ()
copyTopic = do
currentTopic <- realTopic
lastN <- gets (listToMaybe . reverse . sort . mapMaybe (subset currentTopic . W.tag) . W.workspaces . windowset)
addWorkspace (currentTopic ++ ":" ++ (show $ maybe 2 (+1) lastN))
where
subset :: String -> String -> Maybe Int
subset topic other = if topic `isPrefixOf` other then (readM $ tail' $ snd $ break (== ':') other) else Nothing
readM a = case reads a of
[(x,_)] -> Just x
_ -> Nothing
tail' [] = []
tail' xs = tail xs

View File

@ -0,0 +1,20 @@
module TreeSelectUtils where
import XMonad.Actions.TreeSelect
import Data.Tree
import Data.List (sort, groupBy)
import Data.Function (on)
import qualified XMonad.StackSet as W
import XMonad.Core
import Control.Monad.State
-- fromWorkspace :: [String] -> Forest String
fromWorkspace = map go . group . sort
where
group = groupBy ((==) `on` (takeWhile (/= '.')))
go (root:xs) = Node root [Node x [] | x <- xs]
treeselectWorkspaces' conf f = withWindowSet $ \w -> do
let ws = map W.tag . W.hidden $ w
treeselectWorkspace conf (fromWorkspace ws) f

35
src/XMonad/XMobar.hs Normal file
View File

@ -0,0 +1,35 @@
module XMonad.XMobar (zenburnPP) where
-- import XMonad.Util.Loggers
import XMonad.Hooks.DynamicLog (
PP(..)
, xmobarColor
, shorten
, xmobarPP
, dzenStrip)
myUrgencyHintFgColor :: String
myUrgencyHintFgColor = "#333333"
myUrgencyHintBgColor :: String
myUrgencyHintBgColor = "#F18C96"
-- Xmobar pretty printer. Color scheme zenburn
zenburnPP :: PP
zenburnPP = xmobarPP {
ppTitle = xmobarColor "#DCA3A3" "" . shorten 70
, ppCurrent = xmobarColor "#CEFFAC" ""
, ppHidden = const ""
, ppSep = " | "
, ppLayout = id
, ppUrgent = xmobarColor myUrgencyHintFgColor myUrgencyHintBgColor . dzenStrip
, ppOrder = \(ws:_layout:_title:_) -> [ws]
, ppExtras = []
}
-- xmobar :: IO (X ())
-- xmobar = do
-- xmproc <- spawnPipe "xmobar ~/.xmonad/xmobar"
-- return $ dynamicLogWithPP $ zenburnPP xmproc

38
xmonad-masser.cabal Normal file
View File

@ -0,0 +1,38 @@
-- Initial xmonad-masser.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: xmonad-masser
version: 0.1.0.0
-- synopsis:
-- description:
license: BSD3
license-file: LICENSE
author: Mats Rauhala
maintainer: mats.rauhala@iki.fi
-- copyright:
-- category:
build-type: Simple
extra-source-files: ChangeLog.md
cabal-version: >=1.10
library
exposed-modules: XMonad.Config.MasseR
, XMonad.Config.MasseR.ExtraConfig
other-modules: XMonad.Configurable
, XMonad.CustomPrompt
, XMonad.Password
, XMonad.TopicUtils
, XMonad.TopicSpace
, XMonad.XMobar
-- other-extensions:
build-depends: base >=4.11 && <4.12
, xmonad
, xmonad-contrib
, mtl
, directory
, filepath
, unix
, containers
, text
hs-source-dirs: src
default-language: Haskell2010