Initial commit

.gitignore

@@ -0,0 +1 @@
+dist/

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.

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.

Setup.hs

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

default.nix

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

release.nix

@@ -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
+    ];
+  };
+}

shell.nix

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

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

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" [ ("<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

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)

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)

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"

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)
+

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

src/XMonad/Projects.hs

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

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

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

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-<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)]
+

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

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
+

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

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