Make history much, much more reliable.

This time history is being done using a hook to keep track of history.
This means I don't have to manually call pushHistory every time I focus
a new window.

5 files changed, 113 insertions, 147 deletions

diff --git a/src/Rahm/Desktop/History.hs b/src/Rahm/Desktop/History.hs
index 8aff845..dfecc63 100644
--- a/src/Rahm/Desktop/History.hs
+++ b/src/Rahm/Desktop/History.hs
@@ -1,25 +1,92 @@
 module Rahm.Desktop.History where
 
+import XMonad
+import Text.Printf
+import qualified XMonad.StackSet as W
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import Data.Default
+import qualified XMonad.Util.ExtensibleState as XS
 
+import Data.Foldable (toList)
+import Rahm.Desktop.Workspaces (gotoWorkspace)
 import Rahm.Desktop.Hooks.WindowChange
+import Rahm.Desktop.Logger
+import Rahm.Desktop.Marking
+import Data.Sequence (Seq(..))
+import qualified Data.Sequence as Seq
 
-data History = History {
-    currentIndex :: Int
-  , history :: IntMap Location
-  }
+data BoundedSeqZipper a = BoundedSeqZipper Int (Seq a) (Seq a)
+  deriving (Eq, Show, Ord, Read)
+
+instance Functor BoundedSeqZipper where
+  fmap fn (BoundedSeqZipper i h t) = BoundedSeqZipper i (fmap fn h) (fmap fn t)
+
+zipperDbgPrint :: (Show a) => BoundedSeqZipper a -> String
+zipperDbgPrint (BoundedSeqZipper _ h (c :<| t)) =
+  concat $
+    map (printf " %s " . show) (toList h) ++
+    [printf "[%s]" (show c)] ++
+    map (printf " %s " . show) (toList t)
+zipperDbgPrint _ = "<empty>"
+
+pushZipper :: a -> BoundedSeqZipper a -> BoundedSeqZipper a
+pushZipper e (BoundedSeqZipper maxSize _ (tail :|> _))
+    | maxSize <= Seq.length tail =
+  BoundedSeqZipper maxSize mempty (e :<| tail)
+pushZipper e (BoundedSeqZipper maxSize _ tail) =
+  BoundedSeqZipper maxSize mempty (e :<| tail)
+
+getZipper :: BoundedSeqZipper a -> Maybe a
+getZipper (BoundedSeqZipper _ _ (e :<| _)) = Just e
+getZipper _ = Nothing
+
+zipperBack :: BoundedSeqZipper a -> BoundedSeqZipper a
+zipperBack (BoundedSeqZipper s h (e :<| t)) = BoundedSeqZipper s (e :<| h) t
+zipperBack b = b
+
+zipperForward :: BoundedSeqZipper a -> BoundedSeqZipper a
+zipperForward (BoundedSeqZipper s (e :<| h) t) = BoundedSeqZipper s h (e :<| t)
+zipperForward b = b
+
+newtype History = History {
+  currentZipper :: BoundedSeqZipper Location
+} deriving (Read, Show)
 
 instance Default History where
-  def = History 0 IntMap.empty
+  def = History (BoundedSeqZipper 1000 mempty mempty)
 
-addToHistory :: Location -> History -> History
-addToHistory loc (History currentIndex hist) =
-  let hist' = if currentIndex > 100
-                then IntMap.delete (currentIndex - 100) hist
-                else hist
-    in History (currentIndex + 1 ) (IntMap.insert currentIndex loc hist)
+instance ExtensionClass History where
+  initialValue = def
+  -- extensionType = PersistentExtension
+
+historyBack :: X ()
+historyBack = do
+  History z <- XS.get
+  let z' = zipperBack z
+  mapM_ focusLocation (getZipper z')
+  XS.put (History z')
+
+historyForward :: X ()
+historyForward = do
+  History z <- XS.get
+  let z' = zipperForward z
+  mapM_ focusLocation (getZipper z')
+  XS.put (History z')
+
+lastWindow :: X (Maybe Location)
+lastWindow = getZipper . zipperBack . currentZipper <$> XS.get
+
+jumpToLastLocation :: X ()
+jumpToLastLocation = mapM_ focusLocation =<< lastWindow
+  
 
 historyHook :: Location -> Location -> X ()
-historyHook = undefined
+historyHook (Location ws _) l@(Location ws' _) | ws /= ws' = do
+  XS.modify $ \(History z) -> History (pushZipper l z)
+
+historyHook _ _ = return ()
+
+focusLocation :: Location -> X ()
+focusLocation (Location ws Nothing) = gotoWorkspace ws
+focusLocation (Location _ (Just win)) = windows $ W.focusWindow win
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 6912473..388f1bb 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -62,6 +62,7 @@ import Rahm.Desktop.Swallow
 import Rahm.Desktop.SwapMaster (swapMaster)
 import Rahm.Desktop.Windows
 import Rahm.Desktop.Workspaces
+import Rahm.Desktop.History
 
 type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ())
 type ButtonsMap l = XConfig l -> Map (KeyMask, Button) (Window -> X ())
@@ -143,10 +144,10 @@ keymap = runKeys $ do
       doc "Jumps between marks." $
       mapNextString $ \_ str ->
         case str of
-          ['\''] -> jumpToLast
+          ['\''] -> jumpToLastLocation
           [ch] | isAlphaNum ch -> jumpToMark ch
-          "[" -> historyPrev
-          "]" -> historyNext
+          "[" -> historyBack
+          "]" -> historyForward
           _ -> return ()
 
     shiftMod $
@@ -162,7 +163,7 @@ keymap = runKeys $ do
       doc "Swap the current window with a mark." $
       mapNextString $ \_ str ->
         case str of
-          ['\''] ->  swapWithLastMark
+          -- ['\''] ->  swapWithLastMark
           [ch] | isAlphaNum ch -> swapWithMark ch
           _ -> return ()
 
@@ -315,7 +316,7 @@ keymap = runKeys $ do
          \F1: display this help.\n\n\t" $
       mapNextStringWithKeysym $ \_ keysym str ->
         case ((keysym, str), selectWorkspace (keysym, str)) of
-          (_, Just w) -> pushHistory $ gotoWorkspace =<< w
+          (_, Just w) -> gotoWorkspace =<< w
           -- Test binding. Tests that I can still submap keysyms alone (keys
           -- where XLookupString won't return anything helpful.)
           ((f, _), _) | f == xK_F1 -> 
@@ -336,7 +337,7 @@ keymap = runKeys $ do
       doc "Move the current focused window to another workspace and view that workspace" $
       mapNextStringWithKeysym $ \_ keysym str ->
         case ((keysym, str), selectWorkspace (keysym, str)) of
-          (_, Just w) -> pushHistory $ do
+          (_, Just w) -> do
             ws <- w
             shiftToWorkspace ws
             gotoWorkspace ws
@@ -377,7 +378,7 @@ keymap = runKeys $ do
       sendMessage Shrink
 
     shiftMod $
-      doc "Go to the previous window in history." historyPrev
+      doc "Go to the previous window in history." historyBack
 
   bind xK_k $ do
     justMod $
@@ -385,7 +386,7 @@ keymap = runKeys $ do
       sendMessage Expand
 
     shiftMod $
-      doc "Go to the next window in history." historyNext
+      doc "Go to the next window in history." historyForward
 
   bind xK_l $ do
     justMod    $
@@ -551,7 +552,7 @@ keymap = runKeys $ do
 
         bind xK_p $ do
           (justMod -|- noMod) $
-            doc "Go to the prior window in the history" historyPrev
+            doc "Go to the prior window in the history" historyBack
 
         bind xK_t $ do
           (justMod -|- noMod) $ logs "Test Log"
@@ -562,7 +563,7 @@ keymap = runKeys $ do
         --     spawnX (terminal config ++ " -t Notes -e notes new")
         bind xK_n $ do
           (justMod -|- noMod) $
-            doc "Go to the next window in the history" historyNext
+            doc "Go to the next window in the history" historyForward
 
         bind xK_c $ do
           shiftMod $
@@ -606,6 +607,18 @@ keymap = runKeys $ do
             doc "Set the volume of an application via rofi." $
             spawnX "set-volume.sh -a"
 
+        let navigateHistory = repeatable $ do
+              bind xK_bracketright $ do
+                noMod $
+                  doc "Move forward in location history" historyForward
+
+              bind xK_bracketleft $ do
+                noMod $
+                  doc "Move backward in location history" historyBack
+
+        bind xK_bracketleft $ noMod navigateHistory
+        bind xK_bracketright $ noMod navigateHistory
+
         -- Double-tap Z to toggle zoom.
         bind xK_z $ do
           noMod -|- justMod $
@@ -723,8 +736,8 @@ mouseMap = runButtons $ do
             (button4, increaseVolume),
             (button5, decreaseVolume),
             (button2, playPause),
-            (button9, historyNext),
-            (button8, historyPrev),
+            (button9, historyForward),
+            (button8, historyBack),
             (button6, mediaPrev),
             (button7, mediaNext)
             ]
@@ -760,7 +773,7 @@ mouseMap = runButtons $ do
             gotoWorkspace =<< (accompaningWorkspace <$> getCurrentWorkspace)
 
       bind button15 $ do
-        noMod $ noWindow jumpToLast
+        noMod $ noWindow jumpToLastLocation
 
 
       let workspaceButtons = [
diff --git a/src/Rahm/Desktop/Lib.hs b/src/Rahm/Desktop/Lib.hs
index 3b4ee9c..c7cfca4 100644
--- a/src/Rahm/Desktop/Lib.hs
+++ b/src/Rahm/Desktop/Lib.hs
@@ -48,14 +48,14 @@ getString = runQuery $ do
       else printf "%s - %s" t a
 
 askWindowId :: X (Maybe Window)
-askWindowId = pushHistory $ do
+askWindowId = do
   windowTitlesToWinId <- withWindowSet $ \ss ->
     Map.fromList <$> mapM (\wid -> (,) <$> getString wid <*> return wid) (allWindows ss)
 
   runDMenuPromptWithMap "Window" (Just "#f542f5") windowTitlesToWinId
 
 windowJump :: X ()
-windowJump = pushHistory $ do
+windowJump = do
   windowId <- askWindowId
 
   case windowId of
diff --git a/src/Rahm/Desktop/Marking.hs b/src/Rahm/Desktop/Marking.hs
index 98c96bb..639aae2 100644
--- a/src/Rahm/Desktop/Marking.hs
+++ b/src/Rahm/Desktop/Marking.hs
@@ -1,7 +1,6 @@
 module Rahm.Desktop.Marking (
-  historyNext, historyPrev,
-  markCurrentWindow, pushHistory,
-  jumpToMark, jumpToLast, swapWithLastMark,
+  markCurrentWindow,
+  jumpToMark, 
   swapWithMark, markToWindow
   ) where
 
@@ -27,81 +26,19 @@ import qualified Data.Map as Map
 
 type Mark = Char
 
-historySize = 100 -- max number of history elements the tail.
-
-data History a = History [a] (Seq a)
-  deriving (Read, Show)
-
-instance Default (History a) where
-  
-  def = History [] Seq.empty
-
-seqPush :: a -> Seq a -> Seq a
-seqPush elem s@(seq :|> _) | Seq.length s >= historySize = elem :<| seq
-seqPush elem s = elem :<| s
-
-historyForward :: History a -> History a
-historyForward (History (a:as) tail) = History as (seqPush a tail)
-historyForward z = z
-
-historyBackward :: History a -> History a
-historyBackward (History head (a :<| as)) = History (a : head) as
-historyBackward z = z
-
-historyCurrent :: History a -> Maybe a
-historyCurrent (History (a:_) _) = Just a
-historyCurrent _ = Nothing
-
-historyPush :: (Eq a) => a -> History a -> History a
-historyPush a h@(History (w : _) _) | a == w = h
-historyPush a (History (w : _) tail) = History [a] (seqPush w tail)
-historyPush a (History _ tail) = History [a] tail
-
-historySwap :: History a -> History a
-historySwap (History (a:as) (t :<| ts)) = History (t : as) (seqPush a ts)
-historySwap z = z
-
-historyLast :: History a -> Maybe a
-historyLast (History _ (t :<| _)) = Just t
-historyLast _ = Nothing
-
-data Spot =
-        WindowSpot Window | -- Focus is on a window.
-        TagSpot String -- Focus is on an (empty) tag
-        deriving (Read, Show, Eq, Ord)
-
-greedyFocus :: Spot -> X ()
-greedyFocus (WindowSpot win) = do
-     ws <- withWindowSet $ \ss ->
-             return $ getLocationWorkspace =<< findWindow ss win
- 
-     mapM_ (windows . greedyView . tag) ws
-     focus win
-greedyFocus (TagSpot tag) =
-  windows $ greedyView tag
-
 data MarkState =
   MarkState {
     markStateMap :: Map Mark Window
-  , windowHistory :: History Spot
   } deriving (Read, Show)
 
 
 instance ExtensionClass MarkState where
-  initialValue = MarkState Map.empty def
+  initialValue = MarkState Map.empty
   extensionType = PersistentExtension
 
-changeHistory :: (History Spot -> History Spot) -> (MarkState -> MarkState)
-changeHistory fn ms = ms { windowHistory = fn (windowHistory ms)}
-
 withMaybeFocused :: (Maybe Window -> X a) -> X a
 withMaybeFocused f = withWindowSet $ f . peek
 
-normalizeWindows :: X ()
-normalizeWindows = do
-  MarkState { windowHistory = h } <- XS.get
-  mapM_ greedyFocus (historyCurrent h)
-
 -- greedyFocus :: Window -> X ()
 -- greedyFocus win = do
 --     ws <- withWindowSet $ \ss ->
@@ -118,45 +55,12 @@ markCurrentWindow mark = do
           markStateMap = Map.insert mark win ms
         }
 
-pushHistory :: X a -> X a
-pushHistory fn = do
-  withMaybeFocused $ \maybeWindowBefore -> do
-    case maybeWindowBefore of
-      (Just windowBefore) ->
-        XS.modify $ changeHistory (historyPush (WindowSpot windowBefore))
-      Nothing -> 
-        withWindowSet $ \ws ->
-          XS.modify $ changeHistory (historyPush (TagSpot (currentTag ws)))
-
-    ret <- fn
-
-    withMaybeFocused $ \maybeWindowAfter ->
-      case maybeWindowAfter of
-        Just windowAfter ->
-          XS.modify $ changeHistory (historyPush $ WindowSpot windowAfter)
-        Nothing ->
-          withWindowSet $ \ws ->
-            XS.modify $ changeHistory (historyPush $ TagSpot $ currentTag ws)
-
-    return ret
-
-withHistory :: (History Spot -> X ()) -> X ()
-withHistory fn = do
-  MarkState { windowHistory = w } <- XS.get
-  fn w
-
-jumpToLast :: X ()
-jumpToLast = do
-  XS.modify (changeHistory historySwap)
-  normalizeWindows
-
 jumpToMark :: Mark -> X ()
 jumpToMark mark = do
   MarkState {markStateMap = m} <- XS.get
   case Map.lookup mark m of
     Nothing -> return ()
-    Just w -> pushHistory $
-      greedyFocus (WindowSpot w)
+    Just w ->  windows $ focusWindow w
 
 setFocusedWindow :: a -> StackSet i l a s sd -> StackSet i l a s sd
 setFocusedWindow
@@ -177,34 +81,16 @@ swapWithFocused winToSwap stackSet =
           mapWindows (
             \w -> if w == winToSwap then focused else w) stackSet
 
-swapWithLastMark :: X ()
-swapWithLastMark = pushHistory $ withHistory $ \hist -> do
-
-  case historyLast hist of
-    Just (WindowSpot win) ->
-      windows $ swapWithFocused win
-    Nothing -> return ()
-
 markToWindow :: Mark -> X (Maybe Window)
 markToWindow m = do
   MarkState { markStateMap = mp } <- XS.get
   return $ Map.lookup m mp
 
 swapWithMark :: Mark -> X ()
-swapWithMark mark = pushHistory $ do
+swapWithMark mark = do
   MarkState {markStateMap = m} <- XS.get
 
   case Map.lookup mark m of
     Nothing -> return ()
     Just winToSwap -> do
       windows $ swapWithFocused winToSwap
-
-historyPrev :: X ()
-historyPrev = do
-  XS.modify $ changeHistory historyBackward
-  normalizeWindows
-
-historyNext :: X ()
-historyNext = do
-  XS.modify $ changeHistory historyForward
-  normalizeWindows
diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs
index da9fe77..ad245ab 100644
--- a/src/Rahm/Desktop/Submap.hs
+++ b/src/Rahm/Desktop/Submap.hs
@@ -61,7 +61,7 @@ mapNextStringWithKeysym fn = do
 
   ret <- io $ fix $ \nextkey -> do
     ret <-
-      getMaskEventWithTimeout 1000 d keyPressMask $ \p -> do
+      getMaskEventWithTimeout 2000 d keyPressMask $ \p -> do
         KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p
         keysym <- keycodeToKeysym d code 0
         (_, str) <- lookupString (asKeyEvent p)