GTK: implement tabs wrt #45
This also restructures the meaning of MyGUI and MyView. They are now more strictly a hierarchy and everything that may be specific to a view (like urlBar) has been moved into the MyView context. In addition, this also fixes #42
This commit is contained in:
parent
44fc047223
commit
3008e4463b
@ -270,23 +270,13 @@
|
||||
<object class="GtkImage" id="image2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-edit</property>
|
||||
<property name="stock">gtk-open</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image3">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-cancel</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image4">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-zoom-fit</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image5">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-zoom-fit</property>
|
||||
</object>
|
||||
<object class="GtkApplicationWindow" id="rootWin">
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
@ -308,33 +298,6 @@
|
||||
<object class="GtkMenu" id="menu1">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarFileOpen">
|
||||
<property name="label">gtk-open</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarFileExecute">
|
||||
<property name="label">gtk-execute</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarFileNew">
|
||||
<property name="label">gtk-new</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkSeparatorMenuItem" id="separatormenuitem1">
|
||||
<property name="visible">True</property>
|
||||
@ -354,65 +317,6 @@
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkMenuItem" id="menubarEdit">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="label" translatable="yes">_Edit</property>
|
||||
<property name="use_underline">True</property>
|
||||
<child type="submenu">
|
||||
<object class="GtkMenu" id="menu2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarEditCut">
|
||||
<property name="label">gtk-cut</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarEditCopy">
|
||||
<property name="label">gtk-copy</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarEditRename">
|
||||
<property name="label">Move</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image2</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarEditPaste">
|
||||
<property name="label">gtk-paste</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarEditDelete">
|
||||
<property name="label">gtk-delete</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkMenuItem" id="menubarView">
|
||||
<property name="visible">True</property>
|
||||
@ -422,24 +326,6 @@
|
||||
<object class="GtkMenu" id="menu5">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarViewTree">
|
||||
<property name="label">Tree View</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image4</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="menubarViewIcon">
|
||||
<property name="label">Icon view</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image5</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
@ -475,82 +361,27 @@
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkBox" id="box2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<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">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkButton" id="upViewB">
|
||||
<property name="label">gtk-go-up</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="padding">2</property>
|
||||
<property name="position">1</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">2</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkButton" id="refreshViewB">
|
||||
<property name="label">gtk-refresh</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="padding">2</property>
|
||||
<property name="position">3</property>
|
||||
</packing>
|
||||
</child>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkScrolledWindow" id="mainScroll">
|
||||
<property name="width_request">300</property>
|
||||
<property name="height_request">500</property>
|
||||
<object class="GtkNotebook" id="notebook">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="shadow_type">in</property>
|
||||
<child>
|
||||
<placeholder/>
|
||||
</child>
|
||||
<child type="tab">
|
||||
<placeholder/>
|
||||
</child>
|
||||
<child>
|
||||
<placeholder/>
|
||||
</child>
|
||||
<child type="tab">
|
||||
<placeholder/>
|
||||
</child>
|
||||
<child>
|
||||
<placeholder/>
|
||||
</child>
|
||||
<child type="tab">
|
||||
<placeholder/>
|
||||
</child>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">True</property>
|
||||
@ -608,11 +439,26 @@
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
<object class="GtkImage" id="image4">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-zoom-in</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image5">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-zoom-out</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image6">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-directory</property>
|
||||
</object>
|
||||
<object class="GtkImage" id="image7">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-zoom-fit</property>
|
||||
</object>
|
||||
<object class="GtkMenu" id="rcMenu">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
@ -727,5 +573,133 @@
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkSeparatorMenuItem" id="separatormenuitem3">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileView">
|
||||
<property name="label">View</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image7</property>
|
||||
<property name="use_stock">False</property>
|
||||
<child type="submenu">
|
||||
<object class="GtkMenu" id="menu2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileIconView">
|
||||
<property name="label">icon view</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image4</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkImageMenuItem" id="rcFileTreeView">
|
||||
<property name="label" translatable="yes">tree view</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image5</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
</child>
|
||||
</object>
|
||||
<object class="GtkBox" id="viewBox">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="orientation">vertical</property>
|
||||
<child>
|
||||
<object class="GtkBox" id="box2">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<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">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkButton" id="upViewB">
|
||||
<property name="label">gtk-go-up</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="padding">2</property>
|
||||
<property name="position">1</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">2</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkButton" id="refreshViewB">
|
||||
<property name="label">gtk-refresh</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="padding">2</property>
|
||||
<property name="position">3</property>
|
||||
</packing>
|
||||
</child>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkScrolledWindow" id="mainScroll">
|
||||
<property name="width_request">300</property>
|
||||
<property name="height_request">500</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="shadow_type">in</property>
|
||||
<child>
|
||||
<placeholder/>
|
||||
</child>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">True</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
</object>
|
||||
</interface>
|
||||
|
||||
@ -29,6 +29,7 @@ import Data.Maybe
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import qualified HPath as P
|
||||
import HSFM.GUI.Gtk.Callbacks
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import HSFM.GUI.Gtk.MyGUI
|
||||
import HSFM.GUI.Gtk.MyView
|
||||
@ -44,14 +45,13 @@ main = do
|
||||
_ <- initGUI
|
||||
|
||||
args <- SPE.getArgs
|
||||
|
||||
mygui <- createMyGUI
|
||||
|
||||
myview <- createMyView mygui createTreeView
|
||||
|
||||
let mdir = fromMaybe (fromJust $ P.parseAbs "/")
|
||||
(P.parseAbs . headDef "/" $ args)
|
||||
refreshView mygui myview (Just $ mdir)
|
||||
|
||||
mygui <- createMyGUI
|
||||
_ <- newTab mygui createTreeView mdir
|
||||
|
||||
setGUICallbacks mygui
|
||||
|
||||
widgetShowAll (rootWin mygui)
|
||||
|
||||
|
||||
@ -32,8 +32,9 @@ import Control.Exception
|
||||
)
|
||||
import Control.Monad
|
||||
(
|
||||
void
|
||||
, forM_
|
||||
forM_
|
||||
, void
|
||||
, when
|
||||
)
|
||||
import Control.Monad.IO.Class
|
||||
(
|
||||
@ -81,9 +82,35 @@ import System.Posix.Env.ByteString
|
||||
---- MAIN CALLBACK ENTRYPOINT ----
|
||||
|
||||
|
||||
-- |Set callbacks, on hotkeys, events and stuff.
|
||||
setCallbacks :: MyGUI -> MyView -> IO ()
|
||||
setCallbacks mygui myview = do
|
||||
-- |Set callbacks for the whole gui, on hotkeys, events and stuff.
|
||||
setGUICallbacks :: MyGUI -> IO ()
|
||||
setGUICallbacks mygui = do
|
||||
|
||||
_ <- clearStatusBar mygui `on` buttonActivated $ do
|
||||
popStatusbar mygui
|
||||
writeTVarIO (operationBuffer mygui) None
|
||||
|
||||
-- menubar-file
|
||||
_ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $
|
||||
mainQuit
|
||||
|
||||
-- menubar-help
|
||||
_ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $
|
||||
liftIO showAboutDialog
|
||||
return ()
|
||||
|
||||
-- key events
|
||||
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"q" <- fmap glibToString eventKeyName
|
||||
liftIO mainQuit
|
||||
|
||||
return ()
|
||||
|
||||
|
||||
-- |Set callbacks specific to a given view, on hotkeys, events and stuff.
|
||||
setViewCallbacks :: MyGUI -> MyView -> IO ()
|
||||
setViewCallbacks mygui myview = do
|
||||
view' <- readTVarIO $ view myview
|
||||
case view' of
|
||||
fmv@(FMTreeView treeView) -> do
|
||||
@ -126,79 +153,37 @@ setCallbacks mygui myview = do
|
||||
$ (\_ -> withItems mygui myview open)
|
||||
commonGuiEvents fmv
|
||||
return ()
|
||||
menubarCallbacks
|
||||
where
|
||||
menubarCallbacks = do
|
||||
-- menubar-file
|
||||
_ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $
|
||||
mainQuit
|
||||
_ <- (menubarFileOpen . menubar) mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview open
|
||||
_ <- (menubarFileExecute . menubar) mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview execute
|
||||
_ <- (menubarFileNew . menubar) mygui `on` menuItemActivated $
|
||||
liftIO $ newFile mygui myview
|
||||
|
||||
-- menubar-edit
|
||||
_ <- (menubarEditCut . menubar) mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview moveInit
|
||||
_ <- (menubarEditCopy . menubar) mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview copyInit
|
||||
_ <- (menubarEditRename . menubar) mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview renameF
|
||||
_ <- (menubarEditPaste . menubar) mygui `on` menuItemActivated $
|
||||
liftIO $ operationFinal mygui myview Nothing
|
||||
_ <- (menubarEditDelete . menubar) mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview del
|
||||
|
||||
-- mewnubar-view
|
||||
_ <- (menubarViewIcon . menubar) mygui `on` menuItemActivated $
|
||||
liftIO $ switchView mygui myview createIconView
|
||||
_ <- (menubarViewTree . menubar) mygui `on` menuItemActivated $
|
||||
liftIO $ switchView mygui myview createTreeView
|
||||
|
||||
-- menubar-help
|
||||
_ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $
|
||||
liftIO showAboutDialog
|
||||
return ()
|
||||
commonGuiEvents fmv = do
|
||||
let view = fmViewToContainer fmv
|
||||
|
||||
-- GUI events
|
||||
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
|
||||
|
||||
_ <- upViewB mygui `on` buttonActivated $
|
||||
_ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview
|
||||
_ <- upViewB myview `on` buttonActivated $
|
||||
upDir mygui myview
|
||||
_ <- homeViewB mygui `on` buttonActivated $
|
||||
_ <- homeViewB myview `on` buttonActivated $
|
||||
goHome mygui myview
|
||||
_ <- refreshViewB mygui `on` buttonActivated $ do
|
||||
_ <- refreshViewB myview `on` buttonActivated $ do
|
||||
cdir <- liftIO $ getCurrentDir myview
|
||||
refreshView' mygui myview cdir
|
||||
_ <- clearStatusBar mygui `on` buttonActivated $ do
|
||||
popStatusbar mygui
|
||||
writeTVarIO (operationBuffer myview) None
|
||||
|
||||
-- key events
|
||||
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"q" <- fmap glibToString eventKeyName
|
||||
liftIO mainQuit
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"h" <- fmap glibToString eventKeyName
|
||||
cdir <- liftIO $ getCurrentDir myview
|
||||
liftIO $ modifyTVarIO (settings mygui)
|
||||
(\x -> x { showHidden = not . showHidden $ x})
|
||||
>> refreshView' mygui myview cdir
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Alt] <- eventModifier
|
||||
"Up" <- fmap glibToString eventKeyName
|
||||
liftIO $ upDir mygui myview
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Alt] <- eventModifier
|
||||
"Left" <- fmap glibToString eventKeyName
|
||||
liftIO $ goHistoryPrev mygui myview
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Alt] <- eventModifier
|
||||
"Right" <- fmap glibToString eventKeyName
|
||||
liftIO $ goHistoryNext mygui myview
|
||||
@ -217,10 +202,20 @@ setCallbacks mygui myview = do
|
||||
[Control] <- eventModifier
|
||||
"x" <- fmap glibToString eventKeyName
|
||||
liftIO $ withItems mygui myview moveInit
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"v" <- fmap glibToString eventKeyName
|
||||
liftIO $ operationFinal mygui myview Nothing
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"t" <- fmap glibToString eventKeyName
|
||||
liftIO $ void $ do
|
||||
cwd <- getCurrentDir myview
|
||||
newTab mygui createTreeView (path cwd)
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"w" <- fmap glibToString eventKeyName
|
||||
liftIO $ void $ closeTab mygui myview
|
||||
|
||||
-- righ-click
|
||||
_ <- view `on` buttonPressEvent $ do
|
||||
@ -228,7 +223,7 @@ setCallbacks mygui myview = do
|
||||
t <- eventTime
|
||||
case eb of
|
||||
RightButton -> do
|
||||
_ <- liftIO $ menuPopup (rcMenu . rcmenu $ mygui)
|
||||
_ <- liftIO $ menuPopup (rcMenu . rcmenu $ myview)
|
||||
$ Just (RightButton, t)
|
||||
-- this is just to not screw with current selection
|
||||
-- on right-click
|
||||
@ -252,27 +247,34 @@ setCallbacks mygui myview = do
|
||||
return False
|
||||
-- not right-click, so pass on the signal
|
||||
_ -> return False
|
||||
_ <- (rcFileOpen . rcmenu) mygui `on` menuItemActivated $
|
||||
|
||||
-- right click menu
|
||||
_ <- (rcFileOpen . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview open
|
||||
_ <- (rcFileExecute . rcmenu) mygui `on` menuItemActivated $
|
||||
_ <- (rcFileExecute . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview execute
|
||||
_ <- (rcFileNewRegFile . rcmenu) mygui `on` menuItemActivated $
|
||||
_ <- (rcFileNewRegFile . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ newFile mygui myview
|
||||
_ <- (rcFileNewDir . rcmenu) mygui `on` menuItemActivated $
|
||||
_ <- (rcFileNewDir . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ newDir mygui myview
|
||||
_ <- (rcFileCopy . rcmenu) mygui `on` menuItemActivated $
|
||||
_ <- (rcFileCopy . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview copyInit
|
||||
_ <- (rcFileRename . rcmenu) mygui `on` menuItemActivated $
|
||||
_ <- (rcFileRename . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview renameF
|
||||
_ <- (rcFilePaste . rcmenu) mygui `on` menuItemActivated $
|
||||
_ <- (rcFilePaste . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ operationFinal mygui myview Nothing
|
||||
_ <- (rcFileDelete . rcmenu) mygui `on` menuItemActivated $
|
||||
_ <- (rcFileDelete . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview del
|
||||
_ <- (rcFileProperty . rcmenu) mygui `on` menuItemActivated $
|
||||
_ <- (rcFileProperty . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview showFilePropertyDialog
|
||||
_ <- (rcFileCut . rcmenu) mygui `on` menuItemActivated $
|
||||
_ <- (rcFileCut . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview moveInit
|
||||
_ <- (rcFileIconView . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ switchView mygui myview createIconView
|
||||
_ <- (rcFileTreeView . rcmenu) myview `on` menuItemActivated $
|
||||
liftIO $ switchView mygui myview createTreeView
|
||||
return ()
|
||||
|
||||
getPathAtPos fmv (x, y) =
|
||||
case fmv of
|
||||
FMTreeView treeView -> do
|
||||
@ -285,6 +287,16 @@ setCallbacks mygui myview = do
|
||||
|
||||
|
||||
|
||||
---- TAB OPERATIONMS ----
|
||||
|
||||
|
||||
-- |Closes the current tab, but only if there is more than one tab.
|
||||
closeTab :: MyGUI -> MyView -> IO ()
|
||||
closeTab mygui myview = do
|
||||
n <- notebookGetNPages (notebook mygui)
|
||||
when (n > 1) $ void $ destroyView mygui myview
|
||||
|
||||
|
||||
|
||||
---- FILE OPERATION CALLBACKS (COPY, MOVE, ...) ----
|
||||
|
||||
@ -307,8 +319,8 @@ del _ _ _ = withErrorDialog
|
||||
|
||||
-- |Initializes a file move operation.
|
||||
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
moveInit items@(_:_) mygui myview = do
|
||||
writeTVarIO (operationBuffer myview) (FMove . MP1 . map path $ items)
|
||||
moveInit items@(_:_) mygui _ = do
|
||||
writeTVarIO (operationBuffer mygui) (FMove . MP1 . map path $ items)
|
||||
let sbmsg = case items of
|
||||
(item:[]) -> "Move buffer: " ++ getFPasStr item
|
||||
_ -> "Move buffer: " ++ (show . length $ items)
|
||||
@ -321,8 +333,8 @@ moveInit _ _ _ = withErrorDialog
|
||||
|
||||
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
|
||||
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
copyInit items@(_:_) mygui myview = do
|
||||
writeTVarIO (operationBuffer myview) (FCopy . CP1 . map path $ items)
|
||||
copyInit items@(_:_) mygui _ = do
|
||||
writeTVarIO (operationBuffer mygui) (FCopy . CP1 . map path $ items)
|
||||
let sbmsg = case items of
|
||||
(item:[]) -> "Copy buffer: " ++ getFPasStr item
|
||||
_ -> "Copy buffer: " ++ (show . length $ items)
|
||||
@ -337,7 +349,7 @@ copyInit _ _ _ = withErrorDialog
|
||||
-- |Finalizes a file operation, such as copy or move.
|
||||
operationFinal :: MyGUI -> MyView -> Maybe Item -> IO ()
|
||||
operationFinal mygui myview mitem = withErrorDialog $ do
|
||||
op <- readTVarIO (operationBuffer myview)
|
||||
op <- readTVarIO (operationBuffer mygui)
|
||||
cdir <- case mitem of
|
||||
Nothing -> path <$> getCurrentDir myview
|
||||
Just x -> return $ path x
|
||||
@ -350,7 +362,7 @@ operationFinal mygui myview mitem = withErrorDialog $ do
|
||||
$ \cm -> do
|
||||
void $ runFileOp (FMove . MC s cdir $ cm)
|
||||
popStatusbar mygui
|
||||
writeTVarIO (operationBuffer myview) None
|
||||
writeTVarIO (operationBuffer mygui) None
|
||||
FCopy (CP1 s) -> do
|
||||
let cmsg = "Really copy " ++ imsg s
|
||||
++ " to \"" ++ P.fpToString (P.fromAbs cdir)
|
||||
@ -411,7 +423,7 @@ renameF _ _ _ = withErrorDialog
|
||||
-- If the url is invalid, does nothing.
|
||||
urlGoTo :: MyGUI -> MyView -> IO ()
|
||||
urlGoTo mygui myview = withErrorDialog $ do
|
||||
fp <- entryGetText (urlBar mygui)
|
||||
fp <- entryGetText (urlBar myview)
|
||||
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
|
||||
whenM (canOpenDirectory fp')
|
||||
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
|
||||
|
||||
@ -22,4 +22,4 @@ module HSFM.GUI.Gtk.Callbacks where
|
||||
import HSFM.GUI.Gtk.Data
|
||||
|
||||
|
||||
setCallbacks :: MyGUI -> MyView -> IO ()
|
||||
setViewCallbacks :: MyGUI -> MyView -> IO ()
|
||||
|
||||
@ -58,37 +58,47 @@ data MyGUI = MkMyGUI {
|
||||
rootWin :: !Window
|
||||
|
||||
-- widgets on the main window
|
||||
, upViewB :: !Button
|
||||
, homeViewB :: !Button
|
||||
, refreshViewB :: !Button
|
||||
, urlBar :: !Entry
|
||||
, menubar :: !MenuBar
|
||||
, statusBar :: !Statusbar
|
||||
, clearStatusBar :: !Button
|
||||
, scroll :: !ScrolledWindow
|
||||
|
||||
, fprop :: !FilePropertyGrid
|
||||
|
||||
-- sub-widgets
|
||||
, menubar :: !MenuBar
|
||||
, rcmenu :: !RightClickMenu
|
||||
, notebook :: Notebook
|
||||
|
||||
-- other
|
||||
, fprop :: !FilePropertyGrid
|
||||
, settings :: !(TVar FMSettings)
|
||||
|
||||
, operationBuffer :: !(TVar FileOperation)
|
||||
}
|
||||
|
||||
|
||||
-- |This describes the contents of the current vie and is separated from MyGUI,
|
||||
-- because we might want to have multiple views.
|
||||
data MyView = MkMyView {
|
||||
view :: !(TVar FMView)
|
||||
, cwd :: !(MVar Item)
|
||||
, rawModel :: !(TVar (ListStore Item))
|
||||
, sortedModel :: !(TVar (TypedTreeModelSort Item))
|
||||
, filteredModel :: !(TVar (TypedTreeModelFilter Item))
|
||||
, inotify :: !(MVar INotify)
|
||||
|
||||
-- the first part of the tuple represents the "go back"
|
||||
-- the second part the "go forth" in the history
|
||||
, history :: !(TVar ([Path Abs], [Path Abs]))
|
||||
|
||||
-- sub-widgets
|
||||
, scroll :: !ScrolledWindow
|
||||
, viewBox :: !Box
|
||||
, rcmenu :: !RightClickMenu
|
||||
, upViewB :: !Button
|
||||
, homeViewB :: !Button
|
||||
, refreshViewB :: !Button
|
||||
, urlBar :: !Entry
|
||||
}
|
||||
|
||||
|
||||
data MenuBar = MkMenuBar {
|
||||
menubarFileQuit :: !ImageMenuItem
|
||||
, menubarFileOpen :: !ImageMenuItem
|
||||
, menubarFileExecute :: !ImageMenuItem
|
||||
, menubarFileNew :: !ImageMenuItem
|
||||
, menubarEditCut :: !ImageMenuItem
|
||||
, menubarEditCopy :: !ImageMenuItem
|
||||
, menubarEditRename :: !ImageMenuItem
|
||||
, menubarEditPaste :: !ImageMenuItem
|
||||
, menubarEditDelete :: !ImageMenuItem
|
||||
, menubarViewTree :: !ImageMenuItem
|
||||
, menubarViewIcon :: !ImageMenuItem
|
||||
, menubarHelpAbout :: !ImageMenuItem
|
||||
menubarFileQuit :: !ImageMenuItem
|
||||
, menubarHelpAbout :: !ImageMenuItem
|
||||
}
|
||||
|
||||
data RightClickMenu = MkRightClickMenu {
|
||||
@ -103,18 +113,20 @@ data RightClickMenu = MkRightClickMenu {
|
||||
, rcFilePaste :: !ImageMenuItem
|
||||
, rcFileDelete :: !ImageMenuItem
|
||||
, rcFileProperty :: !ImageMenuItem
|
||||
, rcFileIconView :: !ImageMenuItem
|
||||
, rcFileTreeView :: !ImageMenuItem
|
||||
}
|
||||
|
||||
data FilePropertyGrid = MkFilePropertyGrid {
|
||||
fpropGrid :: !Grid
|
||||
, fpropFnEntry :: !Entry
|
||||
, fpropLocEntry :: !Entry
|
||||
, fpropTsEntry :: !Entry
|
||||
, fpropModEntry :: !Entry
|
||||
, fpropAcEntry :: !Entry
|
||||
, fpropFTEntry :: !Entry
|
||||
, fpropPermEntry :: !Entry
|
||||
, fpropLDEntry :: !Entry
|
||||
fpropGrid :: !Grid
|
||||
, fpropFnEntry :: !Entry
|
||||
, fpropLocEntry :: !Entry
|
||||
, fpropTsEntry :: !Entry
|
||||
, fpropModEntry :: !Entry
|
||||
, fpropAcEntry :: !Entry
|
||||
, fpropFTEntry :: !Entry
|
||||
, fpropPermEntry :: !Entry
|
||||
, fpropLDEntry :: !Entry
|
||||
}
|
||||
|
||||
|
||||
@ -131,23 +143,8 @@ data FMView = FMTreeView !TreeView
|
||||
type Item = File FileInfo
|
||||
|
||||
|
||||
-- |This describes the contents of the current vie and is separated from MyGUI,
|
||||
-- because we might want to have multiple views.
|
||||
data MyView = MkMyView {
|
||||
view :: !(TVar FMView)
|
||||
, cwd :: !(MVar Item)
|
||||
, rawModel :: !(TVar (ListStore Item))
|
||||
, sortedModel :: !(TVar (TypedTreeModelSort Item))
|
||||
, filteredModel :: !(TVar (TypedTreeModelFilter Item))
|
||||
, operationBuffer :: !(TVar FileOperation)
|
||||
, inotify :: !(MVar INotify)
|
||||
|
||||
-- the first part of the tuple represents the "go back"
|
||||
-- the second part the "go forth" in the history
|
||||
, history :: !(TVar ([Path Abs], [Path Abs]))
|
||||
}
|
||||
|
||||
|
||||
fmViewToContainer :: FMView -> Container
|
||||
fmViewToContainer (FMTreeView x) = castToContainer . toGObject $ x
|
||||
fmViewToContainer (FMIconView x) = castToContainer . toGObject $ x
|
||||
|
||||
|
||||
@ -27,6 +27,7 @@ import Control.Concurrent.STM
|
||||
newTVarIO
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import HSFM.FileSystem.FileOperations
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import Paths_hsfm
|
||||
(
|
||||
@ -47,6 +48,7 @@ createMyGUI = do
|
||||
|
||||
let settings' = MkFMSettings False True 24
|
||||
settings <- newTVarIO settings'
|
||||
operationBuffer <- newTVarIO None
|
||||
|
||||
builder <- builderNew
|
||||
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
|
||||
@ -54,66 +56,14 @@ createMyGUI = do
|
||||
-- get the pre-defined gui widgets
|
||||
rootWin <- builderGetObject builder castToWindow
|
||||
"rootWin"
|
||||
scroll <- builderGetObject builder castToScrolledWindow
|
||||
"mainScroll"
|
||||
menubarFileQuit <- builderGetObject builder castToImageMenuItem
|
||||
"menubarFileQuit"
|
||||
menubarFileOpen <- builderGetObject builder castToImageMenuItem
|
||||
"menubarFileOpen"
|
||||
menubarFileExecute <- builderGetObject builder castToImageMenuItem
|
||||
"menubarFileExecute"
|
||||
menubarFileNew <- builderGetObject builder castToImageMenuItem
|
||||
"menubarFileNew"
|
||||
menubarEditCut <- builderGetObject builder castToImageMenuItem
|
||||
"menubarEditCut"
|
||||
menubarEditCopy <- builderGetObject builder castToImageMenuItem
|
||||
"menubarEditCopy"
|
||||
menubarEditRename <- builderGetObject builder castToImageMenuItem
|
||||
"menubarEditRename"
|
||||
menubarEditPaste <- builderGetObject builder castToImageMenuItem
|
||||
"menubarEditPaste"
|
||||
menubarEditDelete <- builderGetObject builder castToImageMenuItem
|
||||
"menubarEditDelete"
|
||||
menubarHelpAbout <- builderGetObject builder castToImageMenuItem
|
||||
"menubarHelpAbout"
|
||||
urlBar <- builderGetObject builder castToEntry
|
||||
"urlBar"
|
||||
statusBar <- builderGetObject builder castToStatusbar
|
||||
"statusBar"
|
||||
clearStatusBar <- builderGetObject builder castToButton
|
||||
"clearStatusBar"
|
||||
rcMenu <- builderGetObject builder castToMenu
|
||||
"rcMenu"
|
||||
rcFileOpen <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileOpen"
|
||||
rcFileExecute <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileExecute"
|
||||
rcFileNewRegFile <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileNewRegFile"
|
||||
rcFileNewDir <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileNewDir"
|
||||
rcFileCut <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileCut"
|
||||
rcFileCopy <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileCopy"
|
||||
rcFileRename <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileRename"
|
||||
rcFilePaste <- builderGetObject builder castToImageMenuItem
|
||||
"rcFilePaste"
|
||||
rcFileDelete <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileDelete"
|
||||
rcFileProperty <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileProperty"
|
||||
upViewB <- builderGetObject builder castToButton
|
||||
"upViewB"
|
||||
homeViewB <- builderGetObject builder castToButton
|
||||
"homeViewB"
|
||||
refreshViewB <- builderGetObject builder castToButton
|
||||
"refreshViewB"
|
||||
menubarViewTree <- builderGetObject builder castToImageMenuItem
|
||||
"menubarViewTree"
|
||||
menubarViewIcon <- builderGetObject builder castToImageMenuItem
|
||||
"menubarViewIcon"
|
||||
fpropGrid <- builderGetObject builder castToGrid
|
||||
"fpropGrid"
|
||||
fpropFnEntry <- builderGetObject builder castToEntry
|
||||
@ -132,10 +82,11 @@ createMyGUI = do
|
||||
"fpropPermEntry"
|
||||
fpropLDEntry <- builderGetObject builder castToEntry
|
||||
"fpropLDEntry"
|
||||
notebook <- builderGetObject builder castToNotebook
|
||||
"notebook"
|
||||
|
||||
-- construct the gui object
|
||||
let menubar = MkMenuBar {..}
|
||||
let rcmenu = MkRightClickMenu {..}
|
||||
let fprop = MkFilePropertyGrid {..}
|
||||
let mygui = MkMyGUI {..}
|
||||
|
||||
|
||||
@ -16,7 +16,6 @@ along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||
--}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
|
||||
@ -53,20 +52,23 @@ import HSFM.FileSystem.Errors
|
||||
canOpenDirectory
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setCallbacks)
|
||||
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
|
||||
import HPath
|
||||
(
|
||||
Path
|
||||
, Abs
|
||||
)
|
||||
import qualified HPath as P
|
||||
import HSFM.FileSystem.FileOperations
|
||||
import HSFM.FileSystem.FileType
|
||||
import HSFM.GUI.Glib.GlibString()
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import HSFM.GUI.Gtk.Icons
|
||||
import HSFM.GUI.Gtk.Utils
|
||||
import HSFM.Utils.IO
|
||||
import Paths_hsfm
|
||||
(
|
||||
getDataFileName
|
||||
)
|
||||
import Prelude hiding(readFile)
|
||||
import System.INotify.ByteString
|
||||
(
|
||||
@ -78,6 +80,15 @@ import System.INotify.ByteString
|
||||
|
||||
|
||||
|
||||
-- |Creates a new tab with its own view and refreshes the view.
|
||||
newTab :: MyGUI -> IO FMView -> Path Abs -> IO MyView
|
||||
newTab mygui iofmv path = do
|
||||
myview <- createMyView mygui iofmv
|
||||
_ <- notebookAppendPage (notebook mygui) (viewBox myview)
|
||||
(maybe (P.fromAbs path) P.fromRel $ P.basename path)
|
||||
refreshView mygui myview (Just path)
|
||||
return myview
|
||||
|
||||
|
||||
-- |Constructs the initial MyView object with a few dummy models.
|
||||
-- It also initializes the callbacks.
|
||||
@ -85,11 +96,12 @@ createMyView :: MyGUI
|
||||
-> IO FMView
|
||||
-> IO MyView
|
||||
createMyView mygui iofmv = do
|
||||
operationBuffer <- newTVarIO None
|
||||
|
||||
inotify <- newEmptyMVar
|
||||
history <- newTVarIO ([],[])
|
||||
|
||||
builder <- builderNew
|
||||
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
|
||||
|
||||
-- create dummy models, so we don't have to use MVar
|
||||
rawModel <- newTVarIO =<< listStoreNew []
|
||||
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
|
||||
@ -100,14 +112,56 @@ createMyView mygui iofmv = do
|
||||
view' <- iofmv
|
||||
view <- newTVarIO view'
|
||||
|
||||
urlBar <- builderGetObject builder castToEntry
|
||||
"urlBar"
|
||||
rcMenu <- builderGetObject builder castToMenu
|
||||
"rcMenu"
|
||||
rcFileOpen <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileOpen"
|
||||
rcFileExecute <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileExecute"
|
||||
rcFileNewRegFile <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileNewRegFile"
|
||||
rcFileNewDir <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileNewDir"
|
||||
rcFileCut <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileCut"
|
||||
rcFileCopy <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileCopy"
|
||||
rcFileRename <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileRename"
|
||||
rcFilePaste <- builderGetObject builder castToImageMenuItem
|
||||
"rcFilePaste"
|
||||
rcFileDelete <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileDelete"
|
||||
rcFileProperty <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileProperty"
|
||||
rcFileIconView <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileIconView"
|
||||
rcFileTreeView <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileTreeView"
|
||||
upViewB <- builderGetObject builder castToButton
|
||||
"upViewB"
|
||||
homeViewB <- builderGetObject builder castToButton
|
||||
"homeViewB"
|
||||
refreshViewB <- builderGetObject builder castToButton
|
||||
"refreshViewB"
|
||||
scroll <- builderGetObject builder castToScrolledWindow
|
||||
"mainScroll"
|
||||
viewBox <- builderGetObject builder castToBox
|
||||
"viewBox"
|
||||
|
||||
let rcmenu = MkRightClickMenu {..}
|
||||
let myview = MkMyView {..}
|
||||
|
||||
-- set the bindings
|
||||
setCallbacks mygui myview
|
||||
setViewCallbacks mygui myview
|
||||
|
||||
-- add the treeview to the scroll container
|
||||
let oview = fmViewToContainer view'
|
||||
containerAdd (scroll mygui) oview
|
||||
containerAdd scroll oview
|
||||
|
||||
widgetShowAll viewBox
|
||||
|
||||
return myview
|
||||
|
||||
@ -116,22 +170,41 @@ createMyView mygui iofmv = do
|
||||
-- io action returns.
|
||||
switchView :: MyGUI -> MyView -> IO FMView -> IO ()
|
||||
switchView mygui myview iofmv = do
|
||||
cwd <- getCurrentDir myview
|
||||
|
||||
oldpage <- destroyView mygui myview
|
||||
|
||||
-- create new view and tab page where the previous one was
|
||||
nview <- createMyView mygui iofmv
|
||||
newpage <- notebookInsertPage (notebook mygui) (viewBox nview)
|
||||
(maybe (P.fromAbs $ path cwd) P.fromRel
|
||||
$ P.basename . path $ cwd) oldpage
|
||||
notebookSetCurrentPage (notebook mygui) newpage
|
||||
|
||||
refreshView' mygui nview cwd
|
||||
|
||||
|
||||
-- |Destroys the current view by disconnecting the watcher
|
||||
-- and destroying the active FMView container.
|
||||
--
|
||||
-- Everything that needs to be done in order to forget about a
|
||||
-- view needs to be done here.
|
||||
--
|
||||
-- Returns the page in the tab list this view corresponds to.
|
||||
destroyView :: MyGUI -> MyView -> IO Int
|
||||
destroyView mygui myview = do
|
||||
-- disconnect watcher
|
||||
mi <- tryTakeMVar (inotify myview)
|
||||
for_ mi $ \i -> killINotify i
|
||||
|
||||
page <- notebookGetCurrentPage (notebook mygui)
|
||||
|
||||
-- destroy old view and tab page
|
||||
view' <- readTVarIO $ view myview
|
||||
let oview = fmViewToContainer view'
|
||||
widgetDestroy (fmViewToContainer view')
|
||||
notebookRemovePage (notebook mygui) page
|
||||
|
||||
widgetDestroy oview
|
||||
|
||||
nview' <- iofmv
|
||||
let nview = fmViewToContainer nview'
|
||||
|
||||
writeTVarIO (view myview) nview'
|
||||
|
||||
setCallbacks mygui myview
|
||||
|
||||
containerAdd (scroll mygui) nview
|
||||
widgetShow nview
|
||||
|
||||
refreshView mygui myview Nothing
|
||||
return page
|
||||
|
||||
|
||||
-- |Createss an IconView.
|
||||
@ -231,7 +304,7 @@ refreshView mygui myview mfp =
|
||||
Item)
|
||||
case ecd of
|
||||
Right dir -> return (Just $ path dir)
|
||||
Left _ -> return (P.parseAbs "/")
|
||||
Left _ -> return (P.parseAbs P.pathSeparator')
|
||||
|
||||
|
||||
-- |Refreshes the View based on the given directory.
|
||||
@ -242,14 +315,14 @@ refreshView' :: MyGUI
|
||||
-> MyView
|
||||
-> Item
|
||||
-> IO ()
|
||||
refreshView' mygui myview dt@(DirOrSym _) = do
|
||||
newRawModel <- fileListStore dt myview
|
||||
refreshView' mygui myview item@(DirOrSym _) = do
|
||||
newRawModel <- fileListStore item myview
|
||||
writeTVarIO (rawModel myview) newRawModel
|
||||
|
||||
view' <- readTVarIO $ view myview
|
||||
|
||||
_ <- tryTakeMVar (cwd myview)
|
||||
putMVar (cwd myview) dt
|
||||
putMVar (cwd myview) item
|
||||
|
||||
-- get selected items
|
||||
tps <- getSelectedTreePaths mygui myview
|
||||
@ -257,6 +330,12 @@ refreshView' mygui myview dt@(DirOrSym _) = do
|
||||
|
||||
constructView mygui myview
|
||||
|
||||
-- set notebook tab label
|
||||
page <- notebookGetCurrentPage (notebook mygui)
|
||||
child <- fromJust <$> notebookGetNthPage (notebook mygui) page
|
||||
notebookSetTabLabelText (notebook mygui) child
|
||||
(maybe (P.fromAbs $ path item) P.fromRel $ P.basename . path $ item)
|
||||
|
||||
-- reselect selected items
|
||||
-- TODO: not implemented for icon view yet
|
||||
case view' of
|
||||
@ -301,7 +380,7 @@ constructView mygui myview = do
|
||||
cdirp <- path <$> getCurrentDir myview
|
||||
|
||||
-- update urlBar
|
||||
entrySetText (urlBar mygui) (P.fromAbs cdirp)
|
||||
entrySetText (urlBar myview) (P.fromAbs cdirp)
|
||||
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
|
||||
|
||||
@ -107,6 +107,9 @@ getFirstItem myview = do
|
||||
|
||||
|
||||
-- |Reads the current directory from MyView.
|
||||
--
|
||||
-- This reads the MVar and may block the main thread if it's
|
||||
-- empty.
|
||||
getCurrentDir :: MyView
|
||||
-> IO Item
|
||||
getCurrentDir myview = readMVar (cwd myview)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user