some changes to workspace wheel

1 files changed, 30 insertions, 12 deletions

diff --git a/src/Rahm/Desktop/WorkspaceWheel.hs b/src/Rahm/Desktop/WorkspaceWheel.hs
index eef0ccc..f841bfb 100644
--- a/src/Rahm/Desktop/WorkspaceWheel.hs
+++ b/src/Rahm/Desktop/WorkspaceWheel.hs
@@ -1,6 +1,11 @@
 {-# LANGUAGE MultiWayIf #-}
 
-module Rahm.Desktop.WorkspaceWheel where
+module Rahm.Desktop.WorkspaceWheel
+  ( displayWorkspaceWheel,
+    displayWorkspaceWheelAtPoint,
+    displayWorkspaceWheelInCenter,
+  )
+where
 
 import Control.Arrow (Arrow (first, second))
 import Control.Concurrent (threadDelay)
@@ -8,7 +13,7 @@ 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.Maybe (fromMaybe, isNothing)
 import Data.Monoid (Endo (Endo, appEndo))
 import Data.Ord (comparing)
 import Data.Word
@@ -28,29 +33,39 @@ import XMonad.Util.Run (spawnPipe)
 dzenSize :: (Integral a) => a
 dzenSize = 100
 
-data ScreenType = Current | Visible | Hidden
+data ScreenType = Current | Visible | Hidden deriving (Eq)
 
 displayWorkspaceWheel :: X ()
 displayWorkspaceWheel = uncurry displayWorkspaceWheelAtPoint =<< pointerLocation
 
-data Ring a = Ring [a] (Maybe a) [a]
+data Ring a = Ring Int [a] (Maybe a) [a]
 
 mkRing :: [a] -> Ring a
 mkRing lst =
   let as = cycle lst
       rev = cycle (reverse lst)
-   in Ring rev Nothing as
+   in Ring (length lst) rev Nothing as
 
 ringCur :: Ring a -> Maybe a
-ringCur (Ring _ a _) = 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
+ringAdv (Ring s p Nothing (n : ns)) = Ring s p (Just n) ns
+ringAdv (Ring s p (Just a) (n : ns)) = Ring s (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)
+ringPrev (Ring s (p : ps) Nothing ns) = Ring s ps (Just p) ns
+ringPrev (Ring s (p : ps) (Just a) ns) = Ring s ps (Just p) (a : ns)
+
+ringFastForwardTo :: (a -> Bool) -> Ring a -> Ring a
+ringFastForwardTo fn ring@(Ring s _ a _) =
+  case ringFastForwardTo' fn s ring of
+    ring'@(Ring s' p' (Just a') n') | isNothing a -> Ring s' (a' : p') Nothing n'
+    ring' -> ring'
+  where
+    ringFastForwardTo' _ 0 ring = ring
+    ringFastForwardTo' fn _ ring@(Ring _ _ (Just a) _) | fn a = ring
+    ringFastForwardTo' fn n ring = ringFastForwardTo' fn (n - 1) (ringAdv ring)
 
 displayWorkspaceWheelInCenter :: X ()
 displayWorkspaceWheelInCenter =
@@ -147,7 +162,10 @@ displayWorkspaceWheelAtPoint px py = do
                   return stop
               | otherwise -> return stop
       )
-      (mkRing $ zip dzenPipes rectsToWorkspaces)
+      ( ringFastForwardTo (\(_, (_, (_, n))) -> n == Current) $
+          mkRing $
+            zip dzenPipes rectsToWorkspaces
+      )
 
   io $ do
     mapM_ hClose dzenPipes
@@ -175,7 +193,7 @@ displayWorkspaceWheelAtPoint px py = do
       (Rectangle (toInt -> x) (toInt -> y) (toInt -> w) (toInt -> h))
       as =
         let radius :: (Num a) => a
-            radius = 200
+            radius = 300
 
             nas = max 2 (length as)
             dPhi = 2 * pi / fromIntegral nas