Implement a mouse-driven workspace switcher using dzen.

When a key or button is pressed, RDE will display the set of current
workspaces, prompting the user to click on one to switch to that
workspace.

1 files changed, 106 insertions, 0 deletions

diff --git a/src/Rahm/Desktop/Dzen/WorkspaceSelect.hs b/src/Rahm/Desktop/Dzen/WorkspaceSelect.hs
new file mode 100644
index 0000000..9d12e27
--- /dev/null
+++ b/src/Rahm/Desktop/Dzen/WorkspaceSelect.hs
@@ -0,0 +1,106 @@
+module Rahm.Desktop.Dzen.WorkspaceSelect where
+
+import Control.Arrow (Arrow (first, second))
+import Control.Concurrent (threadDelay)
+import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
+import Data.Function (fix)
+import Data.List (find, sortBy)
+import Data.Ord (comparing)
+import Data.Word
+import qualified Graphics.X11 as X
+import Rahm.Desktop.Common (gotoWorkspace)
+import Rahm.Desktop.StackSet as W
+import Rahm.Desktop.Submap (ButtonOrKeyEvent (ButtonPress), nextButton, nextButtonOrKeyEvent)
+import System.IO
+import Text.Printf (printf)
+import XMonad
+import XMonad.Util.Run (spawnPipe)
+
+dzenSize :: (Integral a) => a
+dzenSize = 100
+
+data ScreenType = Current | Visible | Hidden
+
+displayDzenSelection :: X ()
+displayDzenSelection = do
+  (W.StackSet cur vis other _floating) <- gets windowset
+
+  let allWorkspaces :: [(W.Workspace WorkspaceId (Layout Window) Window, ScreenType)]
+      allWorkspaces =
+        sortBy (comparing (W.tag . fst)) $
+          filter (not . null . W.integrate' . W.stack . fst) $
+            ((W.workspace cur, Current) : map ((,Visible) . W.workspace) vis) ++ map (,Hidden) other
+      (SD rect) = W.screenDetail cur
+      dzenRects = calculatePositions rect allWorkspaces
+      rectsToWorkspaces = map (second (first W.tag)) dzenRects
+
+  dzenPipes <- mapM (uncurry launchDzen) rectsToWorkspaces
+
+  fix $ \retry -> do
+    evt <- runMaybeT nextButtonOrKeyEvent
+
+    case evt of
+      Nothing -> return () -- timeout
+      Just (ButtonPress _ b) | b == button1 -> do
+        withDisplay $ \d -> do
+          (_, _, _, fi -> cx, fi -> cy, _, _, _) <-
+            io $ X.queryPointer d =<< rootWindow d 0
+          case find (\(r, _) -> pointWithin cx cy r) rectsToWorkspaces of
+            Just (_, (ws, _)) -> gotoWorkspace ws
+            Nothing -> return ()
+      _ -> retry
+
+  io $ do
+    mapM_ hClose dzenPipes
+
+  return ()
+  where
+    fi :: (Integral a, Integral b) => a -> b
+    fi = fromIntegral
+
+    toInt :: (Integral a) => a -> Int
+    toInt = fromIntegral
+
+    -- Returns, starting x, dzen width
+    calculatePositions :: Rectangle -> [a] -> [(Rectangle, a)]
+    calculatePositions (Rectangle (toInt -> x) (toInt -> y) (toInt -> w) (toInt -> h)) as =
+      let nas = length as
+          cellSize = (w `div` nas)
+          y' = fi $ (h `div` 2) - (toInt cellSize `div` 2)
+          sz = min 200 (cellSize * 9 `div` 10)
+       in zipWith
+            (\x' a -> (embedRectangle (Rectangle (fi x') (fi y') (fi cellSize) (fi cellSize)) sz sz, a))
+            [x, x + cellSize ..]
+            as
+
+    embedRectangle :: Rectangle -> Int -> Int -> Rectangle
+    embedRectangle r@(Rectangle x y w h) w' h' | w' > fi w || h' > fi h = r
+    embedRectangle (Rectangle x y w h) w' h' =
+      Rectangle
+        (x + fi (w `div` 2) - fi (w' `div` 2))
+        (y + fi (h `div` 2) - fi (h' `div` 2))
+        (fi w')
+        (fi h')
+
+    launchDzen :: Rectangle -> (String, ScreenType) -> X Handle
+    launchDzen (Rectangle x y w h) (wsTag, screenType) = do
+      pipe <-
+        spawnPipe
+          ( printf
+              "dzen2 -fn \"Monofur Nerd Font:size=15:style=bold\" -x %d -y %d -w %d -h %d -bg '%s' -fg '#000000'"
+              x
+              y
+              w
+              h
+              ( case screenType of
+                  Current -> "#ff8888"
+                  Visible -> "#8888ff"
+                  Hidden -> "#888888"
+              )
+          )
+
+      io $ do
+        hPutStrLn pipe wsTag
+        hFlush pipe
+
+      return pipe