diff --git a/data/Gtk/builder.xml b/data/Gtk/builder.xml
index 3601d79..6235565 100644
--- a/data/Gtk/builder.xml
+++ b/data/Gtk/builder.xml
@@ -657,14 +657,17 @@
True
False
-
@@ -684,8 +687,8 @@
-
@@ -712,6 +716,32 @@
3
+
+
+
+ False
+ True
+ 4
+
+
+
+
+
+ True
+ True
+ 5
+
+
False
diff --git a/hsfm.cabal b/hsfm.cabal
index 71747b2..68fea70 100644
--- a/hsfm.cabal
+++ b/hsfm.cabal
@@ -77,6 +77,7 @@ executable hsfm-gtk
hinotify-bytestring,
hpath >= 0.7.3,
hsfm,
+ monad-loops,
old-locale >= 1,
process,
safe,
diff --git a/src/HSFM/GUI/Gtk/Callbacks.hs b/src/HSFM/GUI/Gtk/Callbacks.hs
index fe7afd6..fcd37e8 100644
--- a/src/HSFM/GUI/Gtk/Callbacks.hs
+++ b/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
- , Path
- )
+ (
+ fromAbs
+ , 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)
- for_ mhs $ \hs -> do
- let nhs = goBack hs
- putMVar (history myview) nhs
- nv <- readFile getFileInfo $ currentDir nhs
- goDir False mygui myview nv
+ hs <- takeMVar (history myview)
+ let nhs = historyBack hs
+ putMVar (history myview) nhs
+ nv <- readFile getFileInfo $ currentDir nhs
+ 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)
- for_ mhs $ \hs -> do
- let nhs = goForward hs
- putMVar (history myview) nhs
- nv <- readFile getFileInfo $ currentDir nhs
- goDir False mygui myview nv
+ hs <- takeMVar (history myview)
+ let nhs = historyForward hs
+ putMVar (history myview) nhs
+ nv <- readFile getFileInfo $ currentDir nhs
+ 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
diff --git a/src/HSFM/GUI/Gtk/Callbacks/Utils.hs b/src/HSFM/GUI/Gtk/Callbacks/Utils.hs
index c35dd4d..12a05ca 100644
--- a/src/HSFM/GUI/Gtk/Callbacks/Utils.hs
+++ b/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
diff --git a/src/HSFM/GUI/Gtk/Data.hs b/src/HSFM/GUI/Gtk/Data.hs
index 4ffa3b7..e0bb27f 100644
--- a/src/HSFM/GUI/Gtk/Data.hs
+++ b/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
diff --git a/src/HSFM/GUI/Gtk/MyView.hs b/src/HSFM/GUI/Gtk/MyView.hs
index 21b147f..a4b2d35 100644
--- a/src/HSFM/GUI/Gtk/MyView.hs
+++ b/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
diff --git a/src/HSFM/History.hs b/src/HSFM/History.hs
index 63d99cf..538f71b 100644
--- a/src/HSFM/History.hs
+++ b/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
-goNewPath p (BrowsingHistory b cd _ s) =
+historyNewPath :: Path Abs -> BrowsingHistory -> BrowsingHistory
+historyNewPath p (BrowsingHistory b cd _ s) =
BrowsingHistory (take s $ cd:b) p [] s
--- |Go back in the history.
-goBack :: BrowsingHistory -> BrowsingHistory
-goBack bh@(BrowsingHistory [] _ _ _) = bh
-goBack (BrowsingHistory (b:bs) cd fs s) =
+-- |Go back one step in the history.
+historyBack :: BrowsingHistory -> BrowsingHistory
+historyBack bh@(BrowsingHistory [] _ _ _) = bh
+historyBack (BrowsingHistory (b:bs) cd fs s) =
BrowsingHistory bs b (take s $ cd:fs) s
--- |Go forward in the history.
-goForward :: BrowsingHistory -> BrowsingHistory
-goForward bh@(BrowsingHistory _ _ [] _) = bh
-goForward (BrowsingHistory bs cd (f:fs) s) =
+-- |Go forward one step in the history.
+historyForward :: BrowsingHistory -> BrowsingHistory
+historyForward bh@(BrowsingHistory _ _ [] _) = bh
+historyForward (BrowsingHistory bs cd (f:fs) s) =
BrowsingHistory (take s $ cd:bs) f fs s