Rebrand WorkspaceSelect to "WorkspaceWheel"

Made the selector a wheel instead of a row. Added some keybindings and
button bindings.

1 files changed, 243 insertions, 0 deletions

diff --git a/src/Rahm/Desktop/WorkspaceWheel.hs b/src/Rahm/Desktop/WorkspaceWheel.hs
new file mode 100644
index 0000000..d8f6dfd
--- /dev/null
+++ b/src/Rahm/Desktop/WorkspaceWheel.hs
@@ -0,0 +1,243 @@
+{-# LANGUAGE MultiWayIf #-}
+
+module Rahm.Desktop.WorkspaceWheel where
+
+import Control.Arrow (Arrow (first, second))
+import Control.Concurrent (threadDelay)
+import Control.Monad (forM_)
+import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
+import Data.Function (fix)
+import Data.List (find, sortBy)
+import Data.Maybe (fromMaybe)
+import Data.Monoid (Endo (Endo, appEndo))
+import Data.Ord (comparing)
+import Data.Word
+import qualified Graphics.X11 as X
+import Rahm.Desktop.Common (click, gotoWorkspace, pointerLocation, pointerScreen)
+import Rahm.Desktop.Keys.Wml (getAndResetWindowSelection, getAndResetWindowSelectionOrCurrent)
+import Rahm.Desktop.Layout.PinWindow (withWindowsUnpinned)
+import Rahm.Desktop.Marking (setAlternateWindows, setAlternateWorkspace)
+import Rahm.Desktop.StackSet as W
+import Rahm.Desktop.Submap (ButtonOrKeyEvent (ButtonPress, KeyPress), nextButton, nextButtonOrKeyEvent)
+import System.IO
+import Text.Printf (printf)
+import XMonad
+import qualified XMonad.Operations as X
+import XMonad.Util.Run (spawnPipe)
+
+dzenSize :: (Integral a) => a
+dzenSize = 100
+
+data ScreenType = Current | Visible | Hidden
+
+displayDzenSelection :: X ()
+displayDzenSelection = uncurry displayDzenSelectionAtPoint =<< pointerLocation
+
+data Ring a = Ring [a] (Maybe a) [a]
+
+mkRing :: [a] -> Ring a
+mkRing lst =
+  let as = cycle lst
+      rev = cycle (reverse lst)
+   in Ring rev Nothing as
+
+ringCur :: Ring a -> Maybe a
+ringCur (Ring _ a _) = a
+
+ringAdv :: Ring a -> Ring a
+ringAdv (Ring p Nothing (n : ns)) = Ring p (Just n) ns
+ringAdv (Ring p (Just a) (n : ns)) = Ring (a : p) (Just n) ns
+
+ringPrev :: Ring a -> Ring a
+ringPrev (Ring (p : ps) Nothing ns) = Ring ps (Just p) ns
+ringPrev (Ring (p : ps) (Just a) ns) = Ring ps (Just p) (a : ns)
+
+displayDzenSelectionInCenter :: X ()
+displayDzenSelectionInCenter =
+  mapM_
+    ( \(W.screenDetail -> (SD (Rectangle x y w h))) ->
+        displayDzenSelectionAtPoint
+          (fromIntegral $ x + (fromIntegral w `div` 2))
+          (fromIntegral $ y + (fromIntegral h `div` 2))
+    )
+    =<< pointerScreen
+
+displayDzenSelectionAtPoint :: Int -> Int -> X ()
+displayDzenSelectionAtPoint px py = do
+  click
+
+  (W.StackSet cur vis other _floating) <- gets windowset
+  screen <- fromMaybe cur <$> pointerScreen
+
+  let allWorkspaces :: [(W.Workspace WorkspaceId (Layout Window) Window, ScreenType)]
+      allWorkspaces =
+        sortBy (comparing (W.tag . fst)) $
+          ((W.workspace cur, Current) : map ((,Visible) . W.workspace) vis)
+            ++ filter
+              (\(w, _) -> (not . null . W.integrate' . W.stack) w && W.tag w /= "*")
+              (map (,Hidden) other)
+      (SD rect) = W.screenDetail screen
+      dzenRects = calculatePositions px py rect allWorkspaces
+      rectsToWorkspaces = map (second (first W.tag)) dzenRects
+
+  dzenPipes <- mapM (uncurry launchDzen) rectsToWorkspaces
+
+  after <-
+    ( fix $ \recur ring -> do
+        evt <- runMaybeT nextButtonOrKeyEvent
+        let stop = return ()
+        let retry = recur ring
+
+        case evt of
+          Nothing -> return stop -- timeout
+          Just (ButtonPress _ b) ->
+            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, _)) ->
+                  if
+                    | b == button1 -> do
+                        gotoWorkspace ws
+                        return (displayDzenSelectionAtPoint px py)
+                    | b == button3 -> do
+                        selection <- getAndResetWindowSelectionOrCurrent
+                        withWindowsUnpinned selection $
+                          windows $
+                            appEndo $
+                              mconcat (map (Endo . W.shiftWin ws) selection)
+
+                        return (displayDzenSelectionAtPoint px py)
+                    | b == 13 -> do
+                        winSet <- gets windowset
+                        let mWs = find ((== ws) . W.tag) (W.workspaces winSet)
+                        forM_ mWs $ \ws -> do
+                          let allWindows = W.integrate' (W.stack ws)
+                          setAlternateWindows allWindows
+                          mapM_ (`setAlternateWorkspace` W.tag ws) allWindows
+                          mapM_ killWindow allWindows
+
+                          -- Preemptively delete the windows so we show the updates
+                          -- immediately.
+                          windows $
+                            appEndo $
+                              mconcat $
+                                map (Endo . W.delete) allWindows
+
+                        X.refresh
+                        return (displayDzenSelectionAtPoint px py)
+                    | otherwise -> return stop
+                Nothing -> return stop
+          Just (KeyPress _ sym _ _) -> do
+            if
+              | sym == xK_l -> do
+                  mapM_ deselect (ringCur ring)
+                  let ring' = ringAdv ring
+                  mapM_ select (ringCur ring')
+                  recur ring'
+              | sym == xK_h -> do
+                  mapM_ deselect (ringCur ring)
+                  let ring' = ringPrev ring
+                  mapM_ select (ringCur ring')
+                  recur ring'
+              | sym == xK_space || sym == xK_Return -> do
+                  mapM_
+                    (\(_, (_, (ws, _))) -> gotoWorkspace ws)
+                    (ringCur ring)
+                  return stop
+              | otherwise -> return stop
+      )
+      (mkRing $ zip dzenPipes rectsToWorkspaces)
+
+  io $ do
+    mapM_ hClose dzenPipes
+
+  after
+  where
+    fi :: (Integral a, Num b) => a -> b
+    fi = fromIntegral
+
+    toInt :: (Integral a) => a -> Int
+    toInt = fromIntegral
+
+    deselect :: (Handle, (Rectangle, (String, ScreenType))) -> X ()
+    deselect (pipe, (rect, (wsName, screenType))) = io $ hPutStrLn pipe wsName
+
+    select :: (Handle, (Rectangle, (String, ScreenType))) -> X ()
+    select (pipe, (rect, (wsName, screenType))) =
+      io $ hPutStrLn pipe $ printf "^fg(#ff0)%s" wsName
+
+    -- Returns, starting x, dzen width
+    calculatePositions :: Int -> Int -> Rectangle -> [a] -> [(Rectangle, a)]
+    calculatePositions
+      pointerX'
+      pointerY'
+      (Rectangle (toInt -> x) (toInt -> y) (toInt -> w) (toInt -> h))
+      as =
+        let radius :: (Num a) => a
+            radius = 200
+
+            nas = max 2 (length as)
+            dPhi = 2 * pi / fromIntegral nas
+
+            circDiff = sqrt $ (radius * cos dPhi - radius) ** 2 + (radius * sin dPhi) ** 2
+
+            size :: (Integral a) => a
+            size = round $ min 100 (circDiff * 0.5)
+
+            sizeD2 :: (Integral a) => a
+            sizeD2 = fi size `div` 2
+
+            pointerX =
+              max (radius + sizeD2 + x) $
+                min pointerX' (x + w - radius - sizeD2)
+
+            pointerY =
+              max (radius + sizeD2 + y) $
+                min pointerY' (y + h - radius - sizeD2)
+         in zipWith
+              ( \phi a ->
+                  let xpos = radius * cos phi + fi pointerX
+                      ypos = radius * sin phi + fi pointerY
+                      r =
+                        Rectangle
+                          (round xpos - sizeD2)
+                          (round ypos - sizeD2)
+                          (fi size)
+                          (fi size)
+                   in (r, a)
+              )
+              [3 * pi / 2, 3 * pi / 2 + dPhi ..]
+              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 '#222' -fg '%s'"
+              x
+              y
+              w
+              h
+              ( case screenType of
+                  Current -> "#ff8888"
+                  Visible -> "#8888ff"
+                  Hidden -> "#aaa"
+              )
+          )
+
+      io $ do
+        hPutStrLn pipe wsTag
+        hFlush pipe
+
+      return pipe