From 3b117c4fe0cb4cff0bb6a635531983cd8d58aca6 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 19 Mar 2019 10:10:18 +0200 Subject: [PATCH] Initial commit --- .gitignore | 1 + ChangeLog.md | 5 + LICENSE | 30 +++ Setup.hs | 2 + default.nix | 3 + release.nix | 15 ++ shell.nix | 3 + src/XMonad/Config.hs | 36 ++++ src/XMonad/Config/MasseR.hs | 265 ++++++++++++++++++++++++ src/XMonad/Config/MasseR/ExtraConfig.hs | 14 ++ src/XMonad/Configurable.hs | 17 ++ src/XMonad/CustomPrompt.hs | 14 ++ src/XMonad/Customizations.hs | 21 ++ src/XMonad/Password.hs | 57 +++++ src/XMonad/Projects.hs | 1 + src/XMonad/RestartFile.hs | 47 +++++ src/XMonad/Screen.hs | 38 ++++ src/XMonad/TopicSpace.hs | 59 ++++++ src/XMonad/TopicUtils.hs | 90 ++++++++ src/XMonad/TreeSelectUtils.hs | 20 ++ src/XMonad/XMobar.hs | 35 ++++ xmonad-masser.cabal | 38 ++++ 22 files changed, 811 insertions(+) create mode 100644 .gitignore create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 default.nix create mode 100644 release.nix create mode 100644 shell.nix create mode 100644 src/XMonad/Config.hs create mode 100644 src/XMonad/Config/MasseR.hs create mode 100644 src/XMonad/Config/MasseR/ExtraConfig.hs create mode 100644 src/XMonad/Configurable.hs create mode 100644 src/XMonad/CustomPrompt.hs create mode 100644 src/XMonad/Customizations.hs create mode 100644 src/XMonad/Password.hs create mode 100644 src/XMonad/Projects.hs create mode 100644 src/XMonad/RestartFile.hs create mode 100644 src/XMonad/Screen.hs create mode 100644 src/XMonad/TopicSpace.hs create mode 100644 src/XMonad/TopicUtils.hs create mode 100644 src/XMonad/TreeSelectUtils.hs create mode 100644 src/XMonad/XMobar.hs create mode 100644 xmonad-masser.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..849ddff --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist/ diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..4c98bce --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for xmonad-masser + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..318ae08 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..72ae4b0 --- /dev/null +++ b/default.nix @@ -0,0 +1,3 @@ +{ haskellPackages }: + +haskellPackages.callCabal2nix "xmonad-masser" ./. {} diff --git a/release.nix b/release.nix new file mode 100644 index 0000000..a7a73ad --- /dev/null +++ b/release.nix @@ -0,0 +1,15 @@ +{ nixpkgs ? import {} }: + +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 + ]; + }; +} diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..b3ad7cc --- /dev/null +++ b/shell.nix @@ -0,0 +1,3 @@ +{ nixpkgs ? import {} }: + +(nixpkgs.callPackage ./release.nix {}).shell diff --git a/src/XMonad/Config.hs b/src/XMonad/Config.hs new file mode 100644 index 0000000..7ed6699 --- /dev/null +++ b/src/XMonad/Config.hs @@ -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 diff --git a/src/XMonad/Config/MasseR.hs b/src/XMonad/Config/MasseR.hs new file mode 100644 index 0000000..2cee510 --- /dev/null +++ b/src/XMonad/Config/MasseR.hs @@ -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" [ ("", addName "Suspend machine" $ spawn "sudo pm-suspend") + , ("", addName "Increase volume" $ spawn "amixer set Master 2%+") + , ("", addName "Decrease volume" $ spawn "amixer set Master 2%-") + , ("M-", addName "Increase volume" $ spawn "amixer set Master 2+") + , ("M-", addName "Decrease volume" $ spawn "amixer set Master 2-") + -- , ("", addName "Play/pause spotify" $ spawn "/home/masse/.local/bin/sp play") + , ("", addName "Play/pause mopidy" $ spawn "mpc toggle") + , ("M-m", spotify conf) + , ("M-S-", addName "Swap screens" swapNextScreen) + , ("M-", addName "Kill window" kill) + -- scrot requires `unGrab` + , ("M-", addName "Take screenshot" $ spawn (screenshot . applications $ extraConfig))] ^++^ + subKeys "Launchers" [ ("M-S-y", addName "Open youtube" $ spawn "mpv $(clip -o)") + , ("M-S-", 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-", addName "Toggle layout" $ sendMessage ToggleLayout) + , ("M-", 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 diff --git a/src/XMonad/Config/MasseR/ExtraConfig.hs b/src/XMonad/Config/MasseR/ExtraConfig.hs new file mode 100644 index 0000000..8979419 --- /dev/null +++ b/src/XMonad/Config/MasseR/ExtraConfig.hs @@ -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) diff --git a/src/XMonad/Configurable.hs b/src/XMonad/Configurable.hs new file mode 100644 index 0000000..dd83f13 --- /dev/null +++ b/src/XMonad/Configurable.hs @@ -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) diff --git a/src/XMonad/CustomPrompt.hs b/src/XMonad/CustomPrompt.hs new file mode 100644 index 0000000..f3859b6 --- /dev/null +++ b/src/XMonad/CustomPrompt.hs @@ -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" diff --git a/src/XMonad/Customizations.hs b/src/XMonad/Customizations.hs new file mode 100644 index 0000000..73923a7 --- /dev/null +++ b/src/XMonad/Customizations.hs @@ -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) + diff --git a/src/XMonad/Password.hs b/src/XMonad/Password.hs new file mode 100644 index 0000000..f009161 --- /dev/null +++ b/src/XMonad/Password.hs @@ -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 diff --git a/src/XMonad/Projects.hs b/src/XMonad/Projects.hs new file mode 100644 index 0000000..8cab02e --- /dev/null +++ b/src/XMonad/Projects.hs @@ -0,0 +1 @@ +module Projects where diff --git a/src/XMonad/RestartFile.hs b/src/XMonad/RestartFile.hs new file mode 100644 index 0000000..d9830da --- /dev/null +++ b/src/XMonad/RestartFile.hs @@ -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 diff --git a/src/XMonad/Screen.hs b/src/XMonad/Screen.hs new file mode 100644 index 0000000..f87c67e --- /dev/null +++ b/src/XMonad/Screen.hs @@ -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 diff --git a/src/XMonad/TopicSpace.hs b/src/XMonad/TopicSpace.hs new file mode 100644 index 0000000..db4b099 --- /dev/null +++ b/src/XMonad/TopicSpace.hs @@ -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-", 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)] + diff --git a/src/XMonad/TopicUtils.hs b/src/XMonad/TopicUtils.hs new file mode 100644 index 0000000..26c9624 --- /dev/null +++ b/src/XMonad/TopicUtils.hs @@ -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 diff --git a/src/XMonad/TreeSelectUtils.hs b/src/XMonad/TreeSelectUtils.hs new file mode 100644 index 0000000..c60fd33 --- /dev/null +++ b/src/XMonad/TreeSelectUtils.hs @@ -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 + diff --git a/src/XMonad/XMobar.hs b/src/XMonad/XMobar.hs new file mode 100644 index 0000000..45081b7 --- /dev/null +++ b/src/XMonad/XMobar.hs @@ -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 diff --git a/xmonad-masser.cabal b/xmonad-masser.cabal new file mode 100644 index 0000000..9381a3b --- /dev/null +++ b/xmonad-masser.cabal @@ -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