Rebrand WorkspaceSelect to "WorkspaceWheel"

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

5 files changed, 278 insertions, 125 deletions

diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs
index 713a1d6..6ca3513 100644
--- a/src/Rahm/Desktop/Common.hs
+++ b/src/Rahm/Desktop/Common.hs
@@ -166,6 +166,9 @@ runMaybeT_ = void . runMaybeT
 
 click :: X ()
 click = do
+  ws <- pointerWorkspace
+  mapM_ (windows . S.view) ws
+
   (dpy, root) <- asks $ (,) <$> display <*> X.theRoot
   (_, _, window, _, _, _, _, _) <- io $ X.queryPointer dpy root
   focus window
diff --git a/src/Rahm/Desktop/Dzen/WorkspaceSelect.hs b/src/Rahm/Desktop/Dzen/WorkspaceSelect.hs
deleted file mode 100644
index 2108a7b..0000000
--- a/src/Rahm/Desktop/Dzen/WorkspaceSelect.hs
+++ /dev/null
@@ -1,109 +0,0 @@
-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, pointerLocation, pointerScreen)
-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)
-import Data.Maybe (fromMaybe)
-
-dzenSize :: (Integral a) => a
-dzenSize = 100
-
-data ScreenType = Current | Visible | Hidden
-
-displayDzenSelection :: X ()
-displayDzenSelection = do
-  (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)) $
-          filter (not . null . W.integrate' . W.stack . fst) $
-            ((W.workspace cur, Current) : map ((,Visible) . W.workspace) vis) ++ map (,Hidden) other
-      (SD rect) = W.screenDetail screen
-      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 $ y + (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
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index f4efbb3..2085c22 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -52,6 +52,7 @@ import Rahm.Desktop.Common
     gotoWorkspace,
     locationWindow,
     locationWorkspace,
+    pointerScreen,
     pointerWindow,
     pointerWorkspace,
     runMaybeT_,
@@ -59,7 +60,7 @@ import Rahm.Desktop.Common
   )
 import Rahm.Desktop.DMenu (runDMenu)
 import qualified Rahm.Desktop.Dragging as D
-import Rahm.Desktop.Dzen.WorkspaceSelect (displayDzenSelection)
+import Rahm.Desktop.WorkspaceWheel (displayDzenSelection, displayDzenSelectionAtPoint, displayDzenSelectionInCenter)
 import Rahm.Desktop.History
   ( historyBack,
     historyForward,
@@ -1100,7 +1101,7 @@ bindings = do
 
   bind xK_o $ do
     justMod $
-      doc "Select a workspace using dzen" displayDzenSelection
+      doc "Select a workspace using dzen" displayDzenSelectionInCenter
 
   bind button10 $ do
     noMod $
@@ -1208,6 +1209,13 @@ bindings = do
                     mapM_ X.killWindow =<< getAndResetWindowSelection
                     escape
 
+            bind button10 $
+              noMod $
+                doc "Show dzen selection" $
+                  noWindow $ do
+                    displayDzenSelection
+                    escape
+
             bind button14 $
               noMod $
                 subbind $ do
@@ -1297,7 +1305,11 @@ bindings = do
 
 cornersConfig :: Map ScreenCorner (X ())
 cornersConfig =
-  Map.fromList [(SCUpperLeft, displayDzenSelection)]
+  Map.fromList
+    [ ( SCUpperLeft,
+        displayDzenSelection
+      )
+    ]
 
 --   where
 --
diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs
index 78f02c0..86bc921 100644
--- a/src/Rahm/Desktop/Keys/Wml.hs
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -21,6 +21,7 @@ module Rahm.Desktop.Keys.Wml
     moveLocationToWorkspace,
     moveWindowToWorkspaceFn,
     getAndResetWindowSelection,
+    getAndResetWindowSelectionOrCurrent,
     getWindowSelection,
     gotoWorkspaceFn,
     toggleWindowInSelection,
@@ -66,15 +67,7 @@ import Data.List (find, intercalate, sortOn)
 import Data.List.Safe (head, last)
 import Data.Map (Map)
 import qualified Data.Map as Map
-  ( delete,
-    elems,
-    empty,
-    insert,
-    keys,
-    lookup,
-    member,
-  )
-import Data.Maybe (catMaybes, fromJust, fromMaybe)
+import Data.Maybe (catMaybes, fromJust, fromMaybe, maybeToList)
 import Data.Ord (Down (..))
 import Data.Typeable (cast)
 import Data.Void (Void, absurd)
@@ -103,6 +96,7 @@ import Rahm.Desktop.Marking
     getMarkedLocations,
     windowLocation,
   )
+import Rahm.Desktop.StackSet (StackSet (current))
 import qualified Rahm.Desktop.StackSet as W
 import Rahm.Desktop.Submap (mapNextStringWithKeysym)
 import Rahm.Desktop.Workspaces
@@ -257,6 +251,17 @@ getAndResetWindowSelection = do
   XS.put (initialValue :: WindowSelect)
   return (Map.keys mp)
 
+getAndResetWindowSelectionOrCurrent :: X [Window]
+getAndResetWindowSelectionOrCurrent = do
+  (WindowSelect mp) <- XS.get
+
+  if Map.null mp
+    then withWindowSet $ return . maybeToList . W.peek
+    else do
+      sequence_ (Map.elems mp)
+      XS.put (initialValue :: WindowSelect)
+      return (Map.keys mp)
+
 data Workspace = forall a.
   (Typeable a) =>
   Workspace
@@ -584,7 +589,6 @@ readNextLocationSet' =
 
       -- A character is the base-case. Refers to a collection of windows.
       (_, _, [ch]) | isAlpha ch -> liftXToFeed $ getMarkedLocations [ch]
-
       -- Goes to the most recent location in history.
       -- (_, _, "0") -> (: []) <$> MaybeT (fromX getMostRecentLocationInHistory)
       -- A Digit goes to the past history.
@@ -618,8 +622,9 @@ readNextLocationSet' =
         hoistMaybeT $
           mapM windowLocation =<< nonempty askWindowId
       -- All windows.
-      (_, _, "%") -> hoistMaybeT $
-        mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows))
+      (_, _, "%") ->
+        hoistMaybeT $
+          mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows))
       -- Windows in a workspace
       (_, _, s)
         | s == "\t" || s == "@" || s == "\n" ->
@@ -664,5 +669,4 @@ readNextLocationSet' =
         l1 <- readNextLocationSet
         l2 <- readNextLocationSet
         return $ filter (`elem` l2) l1
-
       _ -> feedFail
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