diff options
| -rw-r--r-- | pager.cabal | 14 | ||||
| -rw-r--r-- | src/desktops.hs | 70 | ||||
| -rw-r--r-- | src/pager.hs (renamed from src/main.hs) | 0 |
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 |