hasufell
/
hsfm
1
1
Fork 0
Code Issues 33 Pull Requests Releases Wiki Activity

GTK: overhaul history feature 

Allowing righ-click menu.
This commit is contained in:
Julian Ospald 2016-06-04 18:58:33 +02:00
parent 05a62cb382
commit 48b0b7b1d8
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
7 changed files with 138 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
data/Gtk/builder.xml
View File

@ -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">
<property name="label">gtk-home</property>
<object class="GtkButton" id="forwardViewB">
<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>

1
hsfm.cabal
View File

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

108
src/HSFM/GUI/Gtk/Callbacks.hs
View File

@ -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

2
src/HSFM/GUI/Gtk/Callbacks/Utils.hs
View File

@ -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

2
src/HSFM/GUI/Gtk/Data.hs
View File

@ -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

4
src/HSFM/GUI/Gtk/MyView.hs
View File

@ -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

20
src/HSFM/History.hs
View File

@ -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