add `desktops` utility

3 files changed, 83 insertions, 1 deletions

diff --git a/pager.cabal b/pager.cabal
index d588963..ee8267e 100644
--- a/pager.cabal
+++ b/pager.cabal
@@ -16,8 +16,20 @@ source-repository this
   location: https://cgit.krebsco.de/pager
   tag: 1.0.0
 
+executable desktops
+  main-is: desktops.hs
+  default-language: Haskell2010
+  ghc-options: -Wall
+  hs-source-dirs: src
+  build-depends: base >= 4.13 && < 5
+               , X11
+               , aeson
+               , bytestring
+               , containers
+               , pager
+
 executable pager
-  main-is: main.hs
+  main-is: pager.hs
   default-language: Haskell2010
   ghc-options: -Wall -threaded -with-rtsopts=-N
   hs-source-dirs: src
diff --git a/src/desktops.hs b/src/desktops.hs
new file mode 100644
index 0000000..fd5f99d
--- /dev/null
+++ b/src/desktops.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE LambdaCase #-}
+module Main (main) where
+
+import Data.Map (Map)
+import Data.Maybe (fromMaybe)
+import Graphics.X11.EWMH (getCurrentDesktop, getDesktopNames, setDesktopNames)
+import Graphics.X11.Extra (withDefaultDisplay)
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy.Char8 as LBS8
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import System.Environment (getArgs)
+
+
+main :: IO ()
+main =
+    getArgs >>= \case
+      [] -> getWorkspaces
+      "get" : [] -> getWorkspaces
+      "add" : names -> addWorkspaces names
+      "remove" : names -> removeWorkspaces names
+      "rename" : name : [] -> renameCurrentWorkspace name
+      "rename" : args | not (null args) && length args `mod` 2 == 0 ->
+          renameWorkspaces renames
+        where
+          renames = Map.fromList (pairUp args)
+          pairUp = \case
+            (x:y:xs) -> (x,y) : pairUp xs
+            _ -> []
+      "set" : names -> setWorkspaces names
+      x -> error $ "bad command: " <> show x
+
+getWorkspaces :: IO ()
+getWorkspaces =
+    LBS8.putStrLn =<< Aeson.encode <$> withDefaultDisplay getDesktopNames
+
+addWorkspaces :: [String] -> IO ()
+addWorkspaces names =
+    withDefaultDisplay $ \dpy -> do
+      names' <-
+        (<>names) .
+        fromMaybe [] <$> getDesktopNames dpy
+      setDesktopNames names' dpy
+
+removeWorkspaces :: [String] -> IO ()
+removeWorkspaces names =
+    withDefaultDisplay $ \dpy -> do
+      names' <-
+        filter (not . flip Set.member (Set.fromList names)) .
+        fromMaybe [] <$> getDesktopNames dpy
+      setDesktopNames names' dpy
+
+renameCurrentWorkspace :: String -> IO ()
+renameCurrentWorkspace name =
+    withDefaultDisplay $ \dpy -> do
+      i <- maybe 0 fromIntegral <$> getCurrentDesktop dpy
+      names <- fromMaybe [] <$> getDesktopNames dpy
+      let names' = take i names <> [name] <> drop (i + 1) names
+      setDesktopNames names' dpy
+
+renameWorkspaces :: Map String String-> IO ()
+renameWorkspaces renames = do
+    withDefaultDisplay $ \dpy -> do
+      names' <-
+        map (\name -> fromMaybe name (Map.lookup name renames)) .
+        fromMaybe [] <$> getDesktopNames dpy
+      setDesktopNames names' dpy
+
+setWorkspaces :: [String] -> IO ()
+setWorkspaces = withDefaultDisplay . setDesktopNames
diff --git a/src/main.hs b/src/pager.hs
index 41c6eec..41c6eec 100644
--- a/src/main.hs
+++ b/src/pager.hs