commit 3b117c4fe0cb4cff0bb6a635531983cd8d58aca6 Author: Mats Rauhala Date: Tue Mar 19 10:10:18 2019 +0200 Initial commit 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