GTK: overhaul history feature

Allowing righ-click menu.

data/Gtk/builder.xml

@@ -657,14 +657,17 @@
         <property name="visible">True</property>
         <property name="can_focus">False</property>
         <child>
-          <object class="GtkEntry" id="urlBar">
+          <object class="GtkButton" id="backViewB">
+            <property name="label">gtk-go-back</property>
             <property name="visible">True</property>
             <property name="can_focus">True</property>
-            <property name="input_purpose">url</property>
+            <property name="receives_default">True</property>
+            <property name="use_stock">True</property>
           </object>
           <packing>
-            <property name="expand">True</property>
+            <property name="expand">False</property>
             <property name="fill">True</property>
+            <property name="padding">2</property>
             <property name="position">0</property>
           </packing>
         </child>
@@ -684,8 +687,8 @@
           </packing>
         </child>
         <child>
-          <object class="GtkButton" id="homeViewB">
+          <object class="GtkButton" id="forwardViewB">
-            <property name="label">gtk-home</property>
+            <property name="label">gtk-go-forward</property>
             <property name="visible">True</property>
             <property name="can_focus">True</property>
             <property name="receives_default">True</property>
@@ -694,6 +697,7 @@
           <packing>
             <property name="expand">False</property>
             <property name="fill">True</property>
+            <property name="padding">2</property>
             <property name="position">2</property>
           </packing>
         </child>
@@ -712,6 +716,32 @@
             <property name="position">3</property>
           </packing>
         </child>
+        <child>
+          <object class="GtkButton" id="homeViewB">
+            <property name="label">gtk-home</property>
+            <property name="visible">True</property>
+            <property name="can_focus">True</property>
+            <property name="receives_default">True</property>
+            <property name="use_stock">True</property>
+          </object>
+          <packing>
+            <property name="expand">False</property>
+            <property name="fill">True</property>
+            <property name="position">4</property>
+          </packing>
+        </child>
+        <child>
+          <object class="GtkEntry" id="urlBar">
+            <property name="visible">True</property>
+            <property name="can_focus">True</property>
+            <property name="input_purpose">url</property>
+          </object>
+          <packing>
+            <property name="expand">True</property>
+            <property name="fill">True</property>
+            <property name="position">5</property>
+          </packing>
+        </child>
       </object>
       <packing>
         <property name="expand">False</property>

hsfm.cabal

@@ -77,6 +77,7 @@ executable hsfm-gtk
                        hinotify-bytestring,
                        hpath >= 0.7.3,
                        hsfm,
+                       monad-loops,
                        old-locale >= 1,
                        process,
                        safe,

src/HSFM/GUI/Gtk/Callbacks.hs

@@ -42,6 +42,10 @@ import Control.Monad.IO.Class
   (
     liftIO
   )
+import Control.Monad.Loops
+  (
+    iterateUntil
+  )
 import Data.ByteString
   (
     ByteString
@@ -58,10 +62,11 @@ import Data.Foldable
 import Graphics.UI.Gtk
 import qualified HPath as P
 import HPath
-    (
+  (
-      Abs
+    fromAbs
-    , Path
+  , Abs
-    )
+  , Path
+  )
 import HPath.IO
 import HPath.IO.Errors
 import HPath.IO.Utils
@@ -91,7 +96,8 @@ import System.Posix.Types
 import Control.Concurrent.MVar
   (
     putMVar
-  , tryTakeMVar
+  , readMVar
+  , takeMVar
   )
 
 
@@ -184,6 +190,34 @@ setViewCallbacks mygui myview = do
       let view = fmViewToContainer fmv
 
       -- GUI events
+      _ <- backViewB myview `on` buttonPressEvent $ do
+        eb <- eventButton
+        t  <- eventTime
+        case eb of
+          LeftButton  -> do
+            liftIO $ void $ goHistoryBack mygui myview
+            return True
+          RightButton -> do
+            his <- liftIO $ readMVar (history myview)
+            menu <- liftIO $ mkHistoryMenuB mygui myview
+                               (backwardsHistory his)
+            _ <- liftIO $ menuPopup menu $ Just (RightButton, t)
+            return True
+          _           -> return False
+      _ <- forwardViewB myview `on` buttonPressEvent $ do
+        eb <- eventButton
+        t  <- eventTime
+        case eb of
+          LeftButton  -> do
+            liftIO $ void $ goHistoryForward mygui myview
+            return True
+          RightButton -> do
+            his <- liftIO $ readMVar (history myview)
+            menu <- liftIO $ mkHistoryMenuF mygui myview
+                               (forwardHistory his)
+            _ <- liftIO $ menuPopup menu $ Just (RightButton, t)
+            return True
+          _           -> return False
       _ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview
       _ <- upViewB myview `on` buttonActivated $
            upDir mygui myview
@@ -208,11 +242,11 @@ setViewCallbacks mygui myview = do
       _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
         [Alt] <- eventModifier
         "Left"  <- fmap glibToString eventKeyName
-        liftIO $ goHistoryBack mygui myview
+        liftIO $ void $ goHistoryBack mygui myview
       _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
         [Alt] <- eventModifier
         "Right"  <- fmap glibToString eventKeyName
-        liftIO $ goHistoryForward mygui myview
+        liftIO $ void $ goHistoryForward mygui myview
       _ <- view `on` keyPressEvent $ tryEvent $ do
         "Delete"  <- fmap glibToString eventKeyName
         liftIO $ withItems mygui myview del
@@ -283,10 +317,10 @@ setViewCallbacks mygui myview = do
               Nothing -> return False
 
           OtherButton 8 -> do
-            liftIO $ goHistoryBack mygui myview
+            liftIO $ void $ goHistoryBack mygui myview
             return False
           OtherButton 9 -> do
-            liftIO $ goHistoryForward mygui myview
+            liftIO $ void $ goHistoryForward mygui myview
             return False
           -- not right-click, so pass on the signal
           _ -> return False
@@ -541,23 +575,51 @@ upDir mygui myview = withErrorDialog $ do
 
 
 -- |Go "back" in the history.
-goHistoryBack :: MyGUI -> MyView -> IO ()
+goHistoryBack :: MyGUI -> MyView -> IO (Path Abs)
 goHistoryBack mygui myview = do
-  mhs <- tryTakeMVar (history myview)
+  hs <- takeMVar (history myview)
-  for_ mhs $ \hs -> do
+  let nhs = historyBack hs
-    let nhs = goBack hs
+  putMVar (history myview) nhs
-    putMVar (history myview) nhs
+  nv <- readFile getFileInfo $ currentDir nhs
-    nv <- readFile getFileInfo $ currentDir nhs
+  goDir False mygui myview nv
-    goDir False mygui myview nv
+  return $ currentDir nhs
 
 
 -- |Go "forward" in the history.
-goHistoryForward :: MyGUI -> MyView -> IO ()
+goHistoryForward :: MyGUI -> MyView -> IO (Path Abs)
 goHistoryForward mygui myview = do
-  mhs <- tryTakeMVar (history myview)
+  hs <- takeMVar (history myview)
-  for_ mhs $ \hs -> do
+  let nhs = historyForward hs
-    let nhs = goForward hs
+  putMVar (history myview) nhs
-    putMVar (history myview) nhs
+  nv <- readFile getFileInfo $ currentDir nhs
-    nv <- readFile getFileInfo $ currentDir nhs
+  goDir False mygui myview nv
-    goDir False mygui myview nv
+  return $ currentDir nhs
+
+
+-- |Show backwards history in a drop-down menu, depending on the input.
+mkHistoryMenuB :: MyGUI -> MyView -> [Path Abs] -> IO Menu
+mkHistoryMenuB mygui myview hs = do
+  menu <- menuNew
+  menuitems <- forM hs $ \p -> do
+    item <- menuItemNewWithLabel (fromAbs p)
+    _ <- item `on` menuItemActivated $
+      void $ iterateUntil (== p) (goHistoryBack mygui myview)
+    return item
+  forM_ menuitems $ \item -> menuShellAppend menu item
+  widgetShowAll menu
+  return menu
+
+
+-- |Show forward history in a drop-down menu, depending on the input.
+mkHistoryMenuF :: MyGUI -> MyView -> [Path Abs] -> IO Menu
+mkHistoryMenuF mygui myview hs = do
+  menu <- menuNew
+  menuitems <- forM hs $ \p -> do
+    item <- menuItemNewWithLabel (fromAbs p)
+    _ <- item `on` menuItemActivated $
+      void $ iterateUntil (== p) (goHistoryForward mygui myview)
+    return item
+  forM_ menuitems $ \item -> menuShellAppend menu item
+  widgetShowAll menu
+  return menu
 

src/HSFM/GUI/Gtk/Callbacks/Utils.hs

@@ -111,7 +111,7 @@ goDir bhis mygui myview item = do
   when bhis $ do
     mhs <- tryTakeMVar (history myview)
     for_ mhs $ \hs -> do
-      let nhs = goNewPath (path item) hs
+      let nhs = historyNewPath (path item) hs
       putMVar (history myview) nhs
   refreshView mygui myview item
 

src/HSFM/GUI/Gtk/Data.hs

@@ -85,7 +85,9 @@ data MyView = MkMyView {
   , scroll       :: !ScrolledWindow
   , viewBox      :: !Box
   , rcmenu       :: !RightClickMenu
+  , backViewB    :: !Button
   , upViewB      :: !Button
+  , forwardViewB :: !Button
   , homeViewB    :: !Button
   , refreshViewB :: !Button
   , urlBar       :: !Entry

src/HSFM/GUI/Gtk/MyView.hs

@@ -189,8 +189,12 @@ createMyView mygui iofmv = do
                        "rcFileIconView"
   rcFileTreeView    <- builderGetObject builder castToImageMenuItem
                        "rcFileTreeView"
+  backViewB         <- builderGetObject builder castToButton
+                       "backViewB"
   upViewB           <- builderGetObject builder castToButton
                        "upViewB"
+  forwardViewB      <- builderGetObject builder castToButton
+                       "forwardViewB"
   homeViewB         <- builderGetObject builder castToButton
                        "homeViewB"
   refreshViewB      <- builderGetObject builder castToButton

src/HSFM/History.hs

@@ -41,21 +41,21 @@ data BrowsingHistory = BrowsingHistory {
 
 -- |This is meant to be called after e.g. a new path is entered
 -- (not navigated to via the history) and the history needs updating.
-goNewPath :: Path Abs -> BrowsingHistory -> BrowsingHistory
+historyNewPath :: Path Abs -> BrowsingHistory -> BrowsingHistory
-goNewPath p (BrowsingHistory b cd _ s) =
+historyNewPath p (BrowsingHistory b cd _ s) =
   BrowsingHistory (take s $ cd:b) p [] s
 
 
--- |Go back in the history.
+-- |Go back one step in the history.
-goBack :: BrowsingHistory -> BrowsingHistory
+historyBack :: BrowsingHistory -> BrowsingHistory
-goBack bh@(BrowsingHistory [] _ _ _)   = bh
+historyBack bh@(BrowsingHistory [] _ _ _)   = bh
-goBack (BrowsingHistory (b:bs) cd fs s) =
+historyBack (BrowsingHistory (b:bs) cd fs s) =
   BrowsingHistory bs b (take s $ cd:fs) s
 
 
--- |Go forward in the history.
+-- |Go forward one step in the history.
-goForward :: BrowsingHistory -> BrowsingHistory
+historyForward :: BrowsingHistory -> BrowsingHistory
-goForward bh@(BrowsingHistory _ _ [] _) = bh
+historyForward bh@(BrowsingHistory _ _ [] _) = bh
-goForward (BrowsingHistory bs cd (f:fs) s) =
+historyForward (BrowsingHistory bs cd (f:fs) s) =
   BrowsingHistory (take s $ cd:bs) f fs s