GTK: add IconView and refactor the modules
This commit is contained in:
parent
2bc406f65e
commit
b266b78e14
@ -99,6 +99,11 @@
|
||||
<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="GtkApplicationWindow" id="rootWin">
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
@ -229,8 +234,31 @@
|
||||
<object class="GtkMenuItem" id="menubarView">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="label" translatable="yes">_View</property>
|
||||
<property name="use_underline">True</property>
|
||||
<property name="label" translatable="yes">View</property>
|
||||
<child type="submenu">
|
||||
<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>
|
||||
</child>
|
||||
<child>
|
||||
@ -280,7 +308,7 @@
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkButton" id="refreshView">
|
||||
<object class="GtkButton" id="refreshViewB">
|
||||
<property name="label">gtk-refresh</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
@ -368,4 +396,9 @@
|
||||
</object>
|
||||
</child>
|
||||
</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>
|
||||
</interface>
|
||||
|
@ -58,6 +58,8 @@ executable hsfm-gtk
|
||||
GUI.Gtk.Data
|
||||
GUI.Gtk.Dialogs
|
||||
GUI.Gtk.Icons
|
||||
GUI.Gtk.MyGUI
|
||||
GUI.Gtk.MyView
|
||||
GUI.Gtk.Utils
|
||||
MyPrelude
|
||||
|
||||
|
263
src/GUI/Gtk.hs
263
src/GUI/Gtk.hs
@ -20,74 +20,11 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Applicative
|
||||
(
|
||||
(<$>)
|
||||
, (<*>)
|
||||
)
|
||||
import Control.Concurrent
|
||||
(
|
||||
forkIO
|
||||
)
|
||||
import Control.Concurrent.MVar
|
||||
(
|
||||
newEmptyMVar
|
||||
)
|
||||
import Control.Concurrent.STM
|
||||
(
|
||||
TVar
|
||||
, newTVarIO
|
||||
, readTVarIO
|
||||
)
|
||||
import Control.Exception
|
||||
(
|
||||
try
|
||||
, Exception
|
||||
, SomeException
|
||||
)
|
||||
import Control.Monad
|
||||
(
|
||||
when
|
||||
, void
|
||||
)
|
||||
import Control.Monad.IO.Class
|
||||
(
|
||||
liftIO
|
||||
)
|
||||
import Data.DirTree
|
||||
import Data.Foldable
|
||||
(
|
||||
for_
|
||||
)
|
||||
import Data.List
|
||||
(
|
||||
sort
|
||||
, isPrefixOf
|
||||
)
|
||||
import Data.Maybe
|
||||
(
|
||||
fromJust
|
||||
, catMaybes
|
||||
, fromMaybe
|
||||
)
|
||||
import Data.Traversable
|
||||
(
|
||||
forM
|
||||
)
|
||||
|
||||
import Graphics.UI.Gtk
|
||||
import GUI.Gtk.Callbacks
|
||||
import GUI.Gtk.Data
|
||||
import GUI.Gtk.Dialogs
|
||||
import GUI.Gtk.Icons
|
||||
import GUI.Gtk.Utils
|
||||
import IO.Error
|
||||
import IO.File
|
||||
import IO.Utils
|
||||
import MyPrelude
|
||||
import Paths_hsfm
|
||||
(
|
||||
getDataFileName
|
||||
)
|
||||
import GUI.Gtk.MyGUI
|
||||
import GUI.Gtk.MyView
|
||||
import Safe
|
||||
(
|
||||
headDef
|
||||
@ -96,28 +33,6 @@ import System.Environment
|
||||
(
|
||||
getArgs
|
||||
)
|
||||
import System.FilePath
|
||||
(
|
||||
isAbsolute
|
||||
, (</>)
|
||||
)
|
||||
import System.Glib.UTFString
|
||||
(
|
||||
glibToString
|
||||
)
|
||||
import System.IO.Unsafe
|
||||
(
|
||||
unsafePerformIO
|
||||
)
|
||||
import System.Process
|
||||
(
|
||||
spawnProcess
|
||||
)
|
||||
|
||||
|
||||
-- TODO: simplify where we modify the TVars
|
||||
-- TODO: double check garbage collection/gtk ref counting
|
||||
-- TODO: file watching, when and what to reread
|
||||
|
||||
|
||||
main :: IO ()
|
||||
@ -126,172 +41,14 @@ main = do
|
||||
|
||||
args <- getArgs
|
||||
|
||||
startMainWindow (headDef "/" args)
|
||||
mygui <- createMyGUI
|
||||
|
||||
myview <- createMyView mygui createTreeView
|
||||
|
||||
refreshView mygui myview (Just $ headDef "/" args)
|
||||
|
||||
widgetShowAll (rootWin mygui)
|
||||
|
||||
_ <- mainGUI
|
||||
return ()
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ Main Window Setup ]--
|
||||
-------------------------
|
||||
|
||||
|
||||
-- |Set up the GUI.
|
||||
--
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'settings' creates
|
||||
-- * 'operationBuffer' creates
|
||||
-- * 'rawModel' creates
|
||||
-- * 'filteredModel' creates
|
||||
-- * 'sortedModel' creates
|
||||
startMainWindow :: FilePath -> IO ()
|
||||
startMainWindow startdir = do
|
||||
|
||||
settings <- newTVarIO (MkFMSettings False True)
|
||||
|
||||
inotify <- newEmptyMVar
|
||||
|
||||
-- get the icons
|
||||
iT <- iconThemeGetDefault
|
||||
folderPix <- getIcon IFolder iT 24
|
||||
folderSymPix <- getSymlinkIcon IFolder iT 24
|
||||
filePix <- getIcon IFile iT 24
|
||||
fileSymPix <- getSymlinkIcon IFile iT 24
|
||||
errorPix <- getIcon IError iT 24
|
||||
|
||||
operationBuffer <- newTVarIO None
|
||||
|
||||
builder <- builderNew
|
||||
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
|
||||
|
||||
-- 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"
|
||||
rcFileNew <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileNew"
|
||||
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"
|
||||
refreshView <- builderGetObject builder castToButton
|
||||
"refreshView"
|
||||
|
||||
-- create initial list store model with unsorted data
|
||||
-- we check that the startdir passed by the user is valid
|
||||
-- TODO: maybe move this to a separate function
|
||||
sd <- (\x -> if (failed . file $ x) || (not . isAbsolute . anchor $ x)
|
||||
then Data.DirTree.readFile "/"
|
||||
else return x) =<< Data.DirTree.readFile startdir
|
||||
rawModel <- newTVarIO =<< listStoreNew
|
||||
=<< Data.DirTree.getContents sd
|
||||
|
||||
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
|
||||
=<< readTVarIO rawModel
|
||||
|
||||
-- create an initial sorting proxy model
|
||||
sortedModel <- newTVarIO =<< treeModelSortNewWithModel
|
||||
=<< readTVarIO filteredModel
|
||||
|
||||
-- create the final view
|
||||
treeView <- treeViewNew
|
||||
-- set selection mode
|
||||
tvs <- treeViewGetSelection treeView
|
||||
treeSelectionSetMode tvs SelectionMultiple
|
||||
|
||||
-- create final tree model columns
|
||||
renderTxt <- cellRendererTextNew
|
||||
renderPix <- cellRendererPixbufNew
|
||||
let ct = cellText :: (CellRendererTextClass cr) => Attr cr String
|
||||
cp = cellPixbuf :: (CellRendererPixbufClass self) => Attr self Pixbuf
|
||||
|
||||
-- filename column
|
||||
cF <- treeViewColumnNew
|
||||
treeViewColumnSetTitle cF "Filename"
|
||||
treeViewColumnSetResizable cF True
|
||||
treeViewColumnSetClickable cF True
|
||||
treeViewColumnSetSortColumnId cF 1
|
||||
cellLayoutPackStart cF renderPix False
|
||||
cellLayoutPackStart cF renderTxt True
|
||||
_ <- treeViewAppendColumn treeView cF
|
||||
cellLayoutAddColumnAttribute cF renderPix cp $ makeColumnIdPixbuf 0
|
||||
cellLayoutAddColumnAttribute cF renderTxt ct $ makeColumnIdString 1
|
||||
|
||||
-- date column
|
||||
cMD <- treeViewColumnNew
|
||||
treeViewColumnSetTitle cMD "Date"
|
||||
treeViewColumnSetResizable cMD True
|
||||
treeViewColumnSetClickable cMD True
|
||||
treeViewColumnSetSortColumnId cMD 2
|
||||
cellLayoutPackStart cMD renderTxt True
|
||||
_ <- treeViewAppendColumn treeView cMD
|
||||
cellLayoutAddColumnAttribute cMD renderTxt ct $ makeColumnIdString 2
|
||||
|
||||
-- permissions column
|
||||
cP <- treeViewColumnNew
|
||||
treeViewColumnSetTitle cP "Permission"
|
||||
treeViewColumnSetResizable cP True
|
||||
treeViewColumnSetClickable cP True
|
||||
treeViewColumnSetSortColumnId cP 3
|
||||
cellLayoutPackStart cP renderTxt True
|
||||
_ <- treeViewAppendColumn treeView cP
|
||||
cellLayoutAddColumnAttribute cP renderTxt ct $ makeColumnIdString 3
|
||||
|
||||
-- construct the gui object
|
||||
let mygui = MkMyGUI {..}
|
||||
let myview = MkMyView {..}
|
||||
|
||||
-- create the tree model with its contents
|
||||
constructTreeView mygui myview
|
||||
|
||||
-- set the bindings
|
||||
setCallbacks mygui myview
|
||||
|
||||
-- add the treeview to the scroll container
|
||||
containerAdd scroll treeView
|
||||
|
||||
-- sets the default icon
|
||||
windowSetDefaultIconFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
|
||||
|
||||
widgetShowAll rootWin
|
||||
|
@ -28,9 +28,7 @@ import Control.Applicative
|
||||
)
|
||||
import Control.Concurrent.STM
|
||||
(
|
||||
TVar
|
||||
, newTVarIO
|
||||
, readTVarIO
|
||||
readTVarIO
|
||||
)
|
||||
import Control.Exception
|
||||
(
|
||||
@ -53,6 +51,7 @@ import Data.Foldable
|
||||
import Graphics.UI.Gtk
|
||||
import GUI.Gtk.Data
|
||||
import GUI.Gtk.Dialogs
|
||||
import GUI.Gtk.MyView
|
||||
import GUI.Gtk.Utils
|
||||
import IO.Error
|
||||
import IO.File
|
||||
@ -77,109 +76,121 @@ import System.Glib.UTFString
|
||||
|
||||
|
||||
-- |Set callbacks, on hotkeys, events and stuff.
|
||||
--
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'settings mygui' modifies
|
||||
setCallbacks :: MyGUI -> MyView -> IO ()
|
||||
setCallbacks mygui myview = do
|
||||
-- GUI events
|
||||
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
|
||||
_ <- treeView mygui `on` rowActivated $ (\_ _ -> withRows mygui myview open)
|
||||
_ <- refreshView mygui `on` buttonActivated $ do
|
||||
cdir <- liftIO $ getCurrentDir myview
|
||||
refreshTreeView' mygui myview cdir
|
||||
_ <- clearStatusBar mygui `on` buttonActivated $ do
|
||||
popStatusbar mygui
|
||||
writeTVarIO (operationBuffer myview) None
|
||||
view' <- readTVarIO $ view myview
|
||||
case view' of
|
||||
FMTreeView treeView -> setTreeViewCallbacks treeView
|
||||
FMIconView iconView -> return ()
|
||||
menubarCallbacks
|
||||
where
|
||||
menubarCallbacks = do
|
||||
-- menubar-file
|
||||
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
|
||||
_ <- menubarFileOpen mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview open
|
||||
_ <- menubarFileExecute mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview execute
|
||||
_ <- menubarFileNew mygui `on` menuItemActivated $
|
||||
liftIO $ newFile mygui myview
|
||||
|
||||
-- key events
|
||||
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"q" <- fmap glibToString eventKeyName
|
||||
liftIO mainQuit
|
||||
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"h" <- fmap glibToString eventKeyName
|
||||
cdir <- liftIO $ getCurrentDir myview
|
||||
liftIO $ modifyTVarIO (settings mygui)
|
||||
(\x -> x { showHidden = not . showHidden $ x})
|
||||
>> refreshTreeView' mygui myview cdir
|
||||
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Alt] <- eventModifier
|
||||
"Up" <- fmap glibToString eventKeyName
|
||||
liftIO $ upDir mygui myview
|
||||
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
|
||||
"Delete" <- fmap glibToString eventKeyName
|
||||
liftIO $ withRows mygui myview del
|
||||
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[] <- eventModifier
|
||||
"Return" <- fmap glibToString eventKeyName
|
||||
liftIO $ withRows mygui myview open
|
||||
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"c" <- fmap glibToString eventKeyName
|
||||
liftIO $ withRows mygui myview copyInit
|
||||
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"x" <- fmap glibToString eventKeyName
|
||||
liftIO $ withRows mygui myview moveInit
|
||||
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"v" <- fmap glibToString eventKeyName
|
||||
liftIO $ operationFinal mygui myview
|
||||
-- menubar-edit
|
||||
_ <- menubarEditCut mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview moveInit
|
||||
_ <- menubarEditCopy mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview copyInit
|
||||
_ <- menubarEditRename mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview renameF
|
||||
_ <- menubarEditPaste mygui `on` menuItemActivated $
|
||||
liftIO $ operationFinal mygui myview
|
||||
_ <- menubarEditDelete mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview del
|
||||
|
||||
-- menubar-file
|
||||
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
|
||||
_ <- menubarFileOpen mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview open
|
||||
_ <- menubarFileExecute mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview execute
|
||||
_ <- menubarFileNew mygui `on` menuItemActivated $
|
||||
liftIO $ newFile mygui myview
|
||||
-- mewnubar-view
|
||||
_ <- menubarViewIcon mygui `on` menuItemActivated $
|
||||
liftIO $ switchView mygui myview createIconView
|
||||
_ <- menubarViewTree mygui `on` menuItemActivated $
|
||||
liftIO $ switchView mygui myview createTreeView
|
||||
|
||||
-- menubar-edit
|
||||
_ <- menubarEditCut mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview moveInit
|
||||
_ <- menubarEditCopy mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview copyInit
|
||||
_ <- menubarEditRename mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview renameF
|
||||
_ <- menubarEditPaste mygui `on` menuItemActivated $
|
||||
liftIO $ operationFinal mygui myview
|
||||
_ <- menubarEditDelete mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview del
|
||||
-- menubar-help
|
||||
_ <- menubarHelpAbout mygui `on` menuItemActivated $
|
||||
liftIO showAboutDialog
|
||||
return ()
|
||||
setTreeViewCallbacks treeView = do
|
||||
-- GUI events
|
||||
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
|
||||
_ <- treeView `on` rowActivated
|
||||
$ (\_ _ -> withItems mygui myview open)
|
||||
_ <- refreshViewB mygui `on` buttonActivated $ do
|
||||
cdir <- liftIO $ getCurrentDir myview
|
||||
refreshView' mygui myview cdir
|
||||
_ <- clearStatusBar mygui `on` buttonActivated $ do
|
||||
popStatusbar mygui
|
||||
writeTVarIO (operationBuffer myview) None
|
||||
|
||||
-- menubar-help
|
||||
_ <- menubarHelpAbout mygui `on` menuItemActivated $
|
||||
liftIO showAboutDialog
|
||||
-- key events
|
||||
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"q" <- fmap glibToString eventKeyName
|
||||
liftIO mainQuit
|
||||
_ <- treeView `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
|
||||
_ <- treeView `on` keyPressEvent $ tryEvent $ do
|
||||
[Alt] <- eventModifier
|
||||
"Up" <- fmap glibToString eventKeyName
|
||||
liftIO $ upDir mygui myview
|
||||
_ <- treeView `on` keyPressEvent $ tryEvent $ do
|
||||
"Delete" <- fmap glibToString eventKeyName
|
||||
liftIO $ withItems mygui myview del
|
||||
_ <- treeView `on` keyPressEvent $ tryEvent $ do
|
||||
[] <- eventModifier
|
||||
"Return" <- fmap glibToString eventKeyName
|
||||
liftIO $ withItems mygui myview open
|
||||
_ <- treeView `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"c" <- fmap glibToString eventKeyName
|
||||
liftIO $ withItems mygui myview copyInit
|
||||
_ <- treeView `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"x" <- fmap glibToString eventKeyName
|
||||
liftIO $ withItems mygui myview moveInit
|
||||
_ <- treeView `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"v" <- fmap glibToString eventKeyName
|
||||
liftIO $ operationFinal mygui myview
|
||||
|
||||
-- righ-click
|
||||
_ <- treeView mygui `on` buttonPressEvent $ do
|
||||
eb <- eventButton
|
||||
t <- eventTime
|
||||
case eb of
|
||||
RightButton -> liftIO $ menuPopup (rcMenu mygui) $ Just (RightButton, t)
|
||||
_ -> return ()
|
||||
return False
|
||||
_ <- rcFileOpen mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview open
|
||||
_ <- rcFileExecute mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview execute
|
||||
_ <- rcFileNew mygui `on` menuItemActivated $
|
||||
liftIO $ newFile mygui myview
|
||||
_ <- rcFileCopy mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview copyInit
|
||||
_ <- rcFileRename mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview renameF
|
||||
_ <- rcFilePaste mygui `on` menuItemActivated $
|
||||
liftIO $ operationFinal mygui myview
|
||||
_ <- rcFileDelete mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview del
|
||||
_ <- rcFileCut mygui `on` menuItemActivated $
|
||||
liftIO $ withRows mygui myview moveInit
|
||||
-- righ-click
|
||||
_ <- treeView `on` buttonPressEvent $ do
|
||||
eb <- eventButton
|
||||
t <- eventTime
|
||||
case eb of
|
||||
RightButton -> liftIO $ menuPopup (rcMenu mygui)
|
||||
$ Just (RightButton, t)
|
||||
_ -> return ()
|
||||
return False
|
||||
_ <- rcFileOpen mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview open
|
||||
_ <- rcFileExecute mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview execute
|
||||
_ <- rcFileNew mygui `on` menuItemActivated $
|
||||
liftIO $ newFile mygui myview
|
||||
_ <- rcFileCopy mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview copyInit
|
||||
_ <- rcFileRename mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview renameF
|
||||
_ <- rcFilePaste mygui `on` menuItemActivated $
|
||||
liftIO $ operationFinal mygui myview
|
||||
_ <- rcFileDelete mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview del
|
||||
_ <- rcFileCut mygui `on` menuItemActivated $
|
||||
liftIO $ withItems mygui myview moveInit
|
||||
|
||||
return ()
|
||||
return ()
|
||||
|
||||
|
||||
-- |Go to the url given at the 'urlBar' and visualize it in the given
|
||||
@ -190,16 +201,16 @@ urlGoTo mygui myview = withErrorDialog $ do
|
||||
let abs = isAbsolute fp
|
||||
exists <- (||) <$> doesDirectoryExist fp <*> doesFileExist fp
|
||||
-- TODO: more explicit error handling?
|
||||
refreshTreeView mygui myview (Just fp)
|
||||
refreshView mygui myview (Just fp)
|
||||
|
||||
|
||||
-- |Supposed to be used with 'withRows'. Opens a file or directory.
|
||||
open :: [Row] -> MyGUI -> MyView -> IO ()
|
||||
open [row] mygui myview = withErrorDialog $
|
||||
case row of
|
||||
open :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
open [item] mygui myview = withErrorDialog $
|
||||
case item of
|
||||
ADirOrSym r -> do
|
||||
nv <- Data.DirTree.readFile $ fullPath r
|
||||
refreshTreeView' mygui myview nv
|
||||
refreshView' mygui myview nv
|
||||
r ->
|
||||
void $ openFile r
|
||||
-- this throws on the first error that occurs
|
||||
@ -211,39 +222,35 @@ open _ _ _ = withErrorDialog
|
||||
|
||||
|
||||
-- |Execute a given file.
|
||||
execute :: [Row] -> MyGUI -> MyView -> IO ()
|
||||
execute [row] mygui myview = withErrorDialog $
|
||||
void $ executeFile row []
|
||||
execute :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
execute [item] mygui myview = withErrorDialog $
|
||||
void $ executeFile item []
|
||||
execute _ _ _ = withErrorDialog
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
|
||||
|
||||
-- |Supposed to be used with 'withRows'. Deletes a file or directory.
|
||||
del :: [Row] -> MyGUI -> MyView -> IO ()
|
||||
del [row] mygui myview = withErrorDialog $ do
|
||||
let cmsg = "Really delete \"" ++ fullPath row ++ "\"?"
|
||||
del :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
del [item] mygui myview = withErrorDialog $ do
|
||||
let cmsg = "Really delete \"" ++ fullPath item ++ "\"?"
|
||||
withConfirmationDialog cmsg
|
||||
$ easyDelete row
|
||||
$ easyDelete item
|
||||
-- this throws on the first error that occurs
|
||||
del rows@(_:_) mygui myview = withErrorDialog $ do
|
||||
let cmsg = "Really delete " ++ show (length rows) ++ " files?"
|
||||
del items@(_:_) mygui myview = withErrorDialog $ do
|
||||
let cmsg = "Really delete " ++ show (length items) ++ " files?"
|
||||
withConfirmationDialog cmsg
|
||||
$ forM_ rows $ \row -> easyDelete row
|
||||
$ forM_ items $ \item -> easyDelete item
|
||||
del _ _ _ = withErrorDialog
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
|
||||
|
||||
-- |Initializes a file move operation.
|
||||
--
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'operationBuffer' writes
|
||||
moveInit :: [Row] -> MyGUI -> MyView -> IO ()
|
||||
moveInit [row] mygui myview = do
|
||||
writeTVarIO (operationBuffer myview) (FMove . MP1 $ row)
|
||||
let sbmsg = "Move buffer: " ++ fullPath row
|
||||
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
moveInit [item] mygui myview = do
|
||||
writeTVarIO (operationBuffer myview) (FMove . MP1 $ item)
|
||||
let sbmsg = "Move buffer: " ++ fullPath item
|
||||
popStatusbar mygui
|
||||
void $ pushStatusBar mygui sbmsg
|
||||
moveInit _ _ _ = withErrorDialog
|
||||
@ -251,14 +258,10 @@ moveInit _ _ _ = withErrorDialog
|
||||
"Operation not supported on multiple files"
|
||||
|
||||
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
|
||||
--
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'operationBuffer' writes
|
||||
copyInit :: [Row] -> MyGUI -> MyView -> IO ()
|
||||
copyInit [row] mygui myview = do
|
||||
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ row)
|
||||
let sbmsg = "Copy buffer: " ++ fullPath row
|
||||
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
copyInit [item] mygui myview = do
|
||||
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ item)
|
||||
let sbmsg = "Copy buffer: " ++ fullPath item
|
||||
popStatusbar mygui
|
||||
void $ pushStatusBar mygui sbmsg
|
||||
copyInit _ _ _ = withErrorDialog
|
||||
@ -267,10 +270,6 @@ copyInit _ _ _ = withErrorDialog
|
||||
|
||||
|
||||
-- |Finalizes a file operation, such as copy or move.
|
||||
--
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'operationBuffer' reads
|
||||
operationFinal :: MyGUI -> MyView -> IO ()
|
||||
operationFinal mygui myview = withErrorDialog $ do
|
||||
op <- readTVarIO (operationBuffer myview)
|
||||
@ -292,18 +291,13 @@ operationFinal mygui myview = withErrorDialog $ do
|
||||
|
||||
|
||||
-- |Go up one directory and visualize it in the treeView.
|
||||
--
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'rawModel' reads
|
||||
-- * 'sortedModel' reads
|
||||
upDir :: MyGUI -> MyView -> IO ()
|
||||
upDir mygui myview = withErrorDialog $ do
|
||||
cdir <- getCurrentDir myview
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
sortedModel' <- readTVarIO $ sortedModel myview
|
||||
nv <- goUp cdir
|
||||
refreshTreeView' mygui myview nv
|
||||
refreshView' mygui myview nv
|
||||
|
||||
|
||||
-- |Go up one directory and visualize it in the treeView.
|
||||
@ -315,13 +309,13 @@ newFile mygui myview = withErrorDialog $ do
|
||||
createFile cdir fn
|
||||
|
||||
|
||||
renameF :: [Row] -> MyGUI -> MyView -> IO ()
|
||||
renameF [row] mygui myview = withErrorDialog $ do
|
||||
renameF :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
renameF [item] mygui myview = withErrorDialog $ do
|
||||
mfn <- textInputDialog "Enter new file name"
|
||||
for_ mfn $ \fn -> do
|
||||
let cmsg = "Really rename \"" ++ fullPath row
|
||||
++ "\"" ++ " to \"" ++ anchor row </> fn ++ "\"?"
|
||||
withConfirmationDialog cmsg $ IO.File.renameFile row fn
|
||||
let cmsg = "Really rename \"" ++ fullPath item
|
||||
++ "\"" ++ " to \"" ++ anchor item </> fn ++ "\"?"
|
||||
withConfirmationDialog cmsg $ IO.File.renameFile item fn
|
||||
renameF _ _ _ = withErrorDialog
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
|
25
src/GUI/Gtk/Callbacks.hs-boot
Normal file
25
src/GUI/Gtk/Callbacks.hs-boot
Normal file
@ -0,0 +1,25 @@
|
||||
{--
|
||||
HSFM, a filemanager written in Haskell.
|
||||
Copyright (C) 2015 Julian Ospald
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
version 2 as published by the Free Software Foundation.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||
--}
|
||||
|
||||
|
||||
module GUI.Gtk.Callbacks where
|
||||
|
||||
import GUI.Gtk.Data
|
||||
|
||||
|
||||
setCallbacks :: MyGUI -> MyView -> IO ()
|
@ -60,6 +60,8 @@ data MyGUI = MkMyGUI {
|
||||
, menubarEditRename :: ImageMenuItem
|
||||
, menubarEditPaste :: ImageMenuItem
|
||||
, menubarEditDelete :: ImageMenuItem
|
||||
, menubarViewTree :: ImageMenuItem
|
||||
, menubarViewIcon :: ImageMenuItem
|
||||
, menubarHelpAbout :: ImageMenuItem
|
||||
, rcMenu :: Menu
|
||||
, rcFileOpen :: ImageMenuItem
|
||||
@ -70,23 +72,17 @@ data MyGUI = MkMyGUI {
|
||||
, rcFileRename :: ImageMenuItem
|
||||
, rcFilePaste :: ImageMenuItem
|
||||
, rcFileDelete :: ImageMenuItem
|
||||
, refreshView :: Button
|
||||
, refreshViewB :: Button
|
||||
, urlBar :: Entry
|
||||
, statusBar :: Statusbar
|
||||
, clearStatusBar :: Button
|
||||
, treeView :: TreeView
|
||||
-- |first column
|
||||
, cF :: TreeViewColumn
|
||||
-- |second column
|
||||
, cMD :: TreeViewColumn
|
||||
, renderTxt :: CellRendererText
|
||||
, renderPix :: CellRendererPixbuf
|
||||
, settings :: TVar FMSettings
|
||||
, folderPix :: Pixbuf
|
||||
, folderSymPix :: Pixbuf
|
||||
, filePix :: Pixbuf
|
||||
, fileSymPix :: Pixbuf
|
||||
, errorPix :: Pixbuf
|
||||
, scroll :: ScrolledWindow
|
||||
}
|
||||
|
||||
|
||||
@ -96,17 +92,24 @@ data FMSettings = MkFMSettings {
|
||||
, isLazy :: Bool
|
||||
}
|
||||
|
||||
data FMView = FMTreeView TreeView
|
||||
| FMIconView IconView
|
||||
|
||||
type Row = AnchoredFile FileInfo
|
||||
type Item = AnchoredFile FileInfo
|
||||
|
||||
|
||||
-- |This describes the contents of the treeView and is separated from MyGUI,
|
||||
-- |This describes the contents of the current vie and is separated from MyGUI,
|
||||
-- because we might want to have multiple views.
|
||||
data MyView = MkMyView {
|
||||
rawModel :: TVar (ListStore Row)
|
||||
, sortedModel :: TVar (TypedTreeModelSort Row)
|
||||
, filteredModel :: TVar (TypedTreeModelFilter Row)
|
||||
view :: TVar FMView
|
||||
, rawModel :: TVar (ListStore Item)
|
||||
, sortedModel :: TVar (TypedTreeModelSort Item)
|
||||
, filteredModel :: TVar (TypedTreeModelFilter Item)
|
||||
, operationBuffer :: TVar FileOperation
|
||||
, inotify :: MVar INotify
|
||||
, inotify :: MVar INotify
|
||||
}
|
||||
|
||||
|
||||
fmViewToContainer :: FMView -> Container
|
||||
fmViewToContainer (FMTreeView x) = castToContainer . toGObject $ x
|
||||
fmViewToContainer (FMIconView x) = castToContainer . toGObject $ x
|
||||
|
123
src/GUI/Gtk/MyGUI.hs
Normal file
123
src/GUI/Gtk/MyGUI.hs
Normal file
@ -0,0 +1,123 @@
|
||||
{--
|
||||
HSFM, a filemanager written in Haskell.
|
||||
Copyright (C) 2015 Julian Ospald
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
version 2 as published by the Free Software Foundation.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||
--}
|
||||
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
module GUI.Gtk.MyGUI where
|
||||
|
||||
|
||||
import Control.Concurrent.STM
|
||||
(
|
||||
newTVarIO
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import GUI.Gtk.Data
|
||||
import GUI.Gtk.Icons
|
||||
import Paths_hsfm
|
||||
(
|
||||
getDataFileName
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ Main Window Setup ]--
|
||||
-------------------------
|
||||
|
||||
|
||||
-- |Set up the GUI. This only creates the permanent widgets.
|
||||
createMyGUI :: IO MyGUI
|
||||
createMyGUI = do
|
||||
|
||||
settings <- newTVarIO (MkFMSettings False True)
|
||||
|
||||
-- get the icons
|
||||
iT <- iconThemeGetDefault
|
||||
folderPix <- getIcon IFolder iT 24
|
||||
folderSymPix <- getSymlinkIcon IFolder iT 24
|
||||
filePix <- getIcon IFile iT 24
|
||||
fileSymPix <- getSymlinkIcon IFile iT 24
|
||||
errorPix <- getIcon IError iT 24
|
||||
|
||||
builder <- builderNew
|
||||
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
|
||||
|
||||
-- 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"
|
||||
rcFileNew <- builderGetObject builder castToImageMenuItem
|
||||
"rcFileNew"
|
||||
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"
|
||||
refreshViewB <- builderGetObject builder castToButton
|
||||
"refreshViewB"
|
||||
menubarViewTree <- builderGetObject builder castToImageMenuItem
|
||||
"menubarViewTree"
|
||||
menubarViewIcon <- builderGetObject builder castToImageMenuItem
|
||||
"menubarViewIcon"
|
||||
|
||||
-- construct the gui object
|
||||
let mygui = MkMyGUI {..}
|
||||
|
||||
-- sets the default icon
|
||||
windowSetDefaultIconFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
|
||||
|
||||
return mygui
|
307
src/GUI/Gtk/MyView.hs
Normal file
307
src/GUI/Gtk/MyView.hs
Normal file
@ -0,0 +1,307 @@
|
||||
{--
|
||||
HSFM, a filemanager written in Haskell.
|
||||
Copyright (C) 2015 Julian Ospald
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
version 2 as published by the Free Software Foundation.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||
--}
|
||||
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
module GUI.Gtk.MyView where
|
||||
|
||||
|
||||
import Control.Applicative
|
||||
(
|
||||
(<$>)
|
||||
)
|
||||
import Control.Concurrent.MVar
|
||||
(
|
||||
newEmptyMVar
|
||||
, putMVar
|
||||
, tryTakeMVar
|
||||
)
|
||||
import Control.Concurrent.STM
|
||||
(
|
||||
newTVarIO
|
||||
, readTVarIO
|
||||
)
|
||||
import Data.DirTree
|
||||
import Data.Foldable
|
||||
(
|
||||
for_
|
||||
)
|
||||
import Data.Maybe
|
||||
(
|
||||
catMaybes
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import {-# SOURCE #-} GUI.Gtk.Callbacks (setCallbacks)
|
||||
import GUI.Gtk.Data
|
||||
import GUI.Gtk.Utils
|
||||
import IO.File
|
||||
import IO.Utils
|
||||
import System.FilePath
|
||||
(
|
||||
isAbsolute
|
||||
)
|
||||
import System.INotify
|
||||
(
|
||||
addWatch
|
||||
, initINotify
|
||||
, killINotify
|
||||
, EventVariety(..)
|
||||
, Event(..)
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
-- |Constructs the initial MyView object with a few dummy models.
|
||||
-- It also initializes the callbacks.
|
||||
createMyView :: MyGUI -> IO FMView -> IO MyView
|
||||
createMyView mygui iofmv = do
|
||||
operationBuffer <- newTVarIO None
|
||||
|
||||
inotify <- newEmptyMVar
|
||||
|
||||
-- create dummy models, so we don't have to use MVar
|
||||
rawModel <- newTVarIO =<< listStoreNew []
|
||||
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
|
||||
=<< readTVarIO rawModel
|
||||
sortedModel <- newTVarIO =<< treeModelSortNewWithModel
|
||||
=<< readTVarIO filteredModel
|
||||
|
||||
view' <- iofmv
|
||||
view <- newTVarIO view'
|
||||
|
||||
let myview = MkMyView {..}
|
||||
|
||||
-- set the bindings
|
||||
setCallbacks mygui myview
|
||||
|
||||
-- add the treeview to the scroll container
|
||||
let oview = fmViewToContainer view'
|
||||
containerAdd (scroll mygui) oview
|
||||
|
||||
return myview
|
||||
|
||||
|
||||
-- |Switch the existing view in `MyView` with the one that the
|
||||
-- io action returns.
|
||||
switchView :: MyGUI -> MyView -> IO FMView -> IO ()
|
||||
switchView mygui myview iofmv = do
|
||||
view' <- readTVarIO $ view myview
|
||||
let oview = fmViewToContainer view'
|
||||
|
||||
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
|
||||
|
||||
|
||||
-- |Createss an IconView.
|
||||
createIconView :: IO FMView
|
||||
createIconView = do
|
||||
iconv <- iconViewNew
|
||||
iconViewSetSelectionMode iconv SelectionMultiple
|
||||
iconViewSetColumns iconv (-1)
|
||||
iconViewSetSpacing iconv 2
|
||||
iconViewSetMargin iconv 0
|
||||
|
||||
return $ FMIconView iconv
|
||||
|
||||
|
||||
-- |Creates a TreeView.
|
||||
createTreeView :: IO FMView
|
||||
createTreeView = do
|
||||
-- create the final view
|
||||
treeView <- treeViewNew
|
||||
-- set selection mode
|
||||
tvs <- treeViewGetSelection treeView
|
||||
treeSelectionSetMode tvs SelectionMultiple
|
||||
|
||||
-- create final tree model columns
|
||||
renderTxt <- cellRendererTextNew
|
||||
renderPix <- cellRendererPixbufNew
|
||||
let ct = cellText :: (CellRendererTextClass cr) => Attr cr String
|
||||
cp = cellPixbuf :: (CellRendererPixbufClass self) => Attr self Pixbuf
|
||||
|
||||
-- filename column
|
||||
cF <- treeViewColumnNew
|
||||
treeViewColumnSetTitle cF "Filename"
|
||||
treeViewColumnSetResizable cF True
|
||||
treeViewColumnSetClickable cF True
|
||||
treeViewColumnSetSortColumnId cF 1
|
||||
cellLayoutPackStart cF renderPix False
|
||||
cellLayoutPackStart cF renderTxt True
|
||||
_ <- treeViewAppendColumn treeView cF
|
||||
cellLayoutAddColumnAttribute cF renderPix cp $ makeColumnIdPixbuf 0
|
||||
cellLayoutAddColumnAttribute cF renderTxt ct $ makeColumnIdString 1
|
||||
|
||||
-- date column
|
||||
cMD <- treeViewColumnNew
|
||||
treeViewColumnSetTitle cMD "Date"
|
||||
treeViewColumnSetResizable cMD True
|
||||
treeViewColumnSetClickable cMD True
|
||||
treeViewColumnSetSortColumnId cMD 2
|
||||
cellLayoutPackStart cMD renderTxt True
|
||||
_ <- treeViewAppendColumn treeView cMD
|
||||
cellLayoutAddColumnAttribute cMD renderTxt ct $ makeColumnIdString 2
|
||||
|
||||
-- permissions column
|
||||
cP <- treeViewColumnNew
|
||||
treeViewColumnSetTitle cP "Permission"
|
||||
treeViewColumnSetResizable cP True
|
||||
treeViewColumnSetClickable cP True
|
||||
treeViewColumnSetSortColumnId cP 3
|
||||
cellLayoutPackStart cP renderTxt True
|
||||
_ <- treeViewAppendColumn treeView cP
|
||||
cellLayoutAddColumnAttribute cP renderTxt ct $ makeColumnIdString 3
|
||||
|
||||
return $ FMTreeView treeView
|
||||
|
||||
|
||||
-- |Re-reads the current directory or the given one and updates the View.
|
||||
refreshView :: MyGUI
|
||||
-> MyView
|
||||
-> Maybe FilePath
|
||||
-> IO ()
|
||||
refreshView mygui myview mfp =
|
||||
case mfp of
|
||||
Just fp -> do
|
||||
cdir <- (\x -> if (failed . file $ x) || (not . isAbsolute . anchor $ x)
|
||||
then Data.DirTree.readFile "/"
|
||||
else return x) =<< Data.DirTree.readFile fp
|
||||
refreshView' mygui myview cdir
|
||||
Nothing -> refreshView' mygui myview =<< getCurrentDir myview
|
||||
|
||||
|
||||
-- |Refreshes the View based on the given directory.
|
||||
refreshView' :: MyGUI
|
||||
-> MyView
|
||||
-> AnchoredFile FileInfo
|
||||
-> IO ()
|
||||
refreshView' mygui myview dt@(ADirOrSym _) = do
|
||||
newRawModel <- fileListStore dt myview
|
||||
writeTVarIO (rawModel myview) newRawModel
|
||||
|
||||
view' <- readTVarIO $ view myview
|
||||
|
||||
-- get selected items
|
||||
tps <- getSelectedTreePaths mygui myview
|
||||
trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps
|
||||
|
||||
constructView mygui myview
|
||||
|
||||
-- reselect selected items
|
||||
-- TODO: not implemented for icon view yet
|
||||
case view' of
|
||||
FMTreeView treeView -> do
|
||||
tvs <- treeViewGetSelection treeView
|
||||
ntps <- mapM treeRowReferenceGetPath trs
|
||||
mapM_ (treeSelectionSelectPath tvs) ntps
|
||||
_ -> return ()
|
||||
refreshView' _ _ _ = return ()
|
||||
|
||||
|
||||
-- |Constructs the visible View with the current underlying mutable models,
|
||||
-- which are retrieved from 'MyGUI'.
|
||||
--
|
||||
-- This sort of merges the components mygui and myview and fires up
|
||||
-- the actual models.
|
||||
constructView :: MyGUI
|
||||
-> MyView
|
||||
-> IO ()
|
||||
constructView mygui myview = do
|
||||
view' <- readTVarIO $ view myview
|
||||
|
||||
cdirp <- anchor <$> getFirstItem myview
|
||||
|
||||
-- update urlBar
|
||||
entrySetText (urlBar mygui) cdirp
|
||||
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
|
||||
-- filtering
|
||||
filteredModel' <- treeModelFilterNew rawModel' []
|
||||
writeTVarIO (filteredModel myview) filteredModel'
|
||||
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
|
||||
hidden <- showHidden <$> readTVarIO (settings mygui)
|
||||
item <- (name . file) <$> treeModelGetRow rawModel' iter
|
||||
if hidden
|
||||
then return True
|
||||
else return $ not . hiddenFile $ item
|
||||
|
||||
-- sorting
|
||||
sortedModel' <- treeModelSortNewWithModel filteredModel'
|
||||
writeTVarIO (sortedModel myview) sortedModel'
|
||||
treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
|
||||
cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
|
||||
cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
|
||||
item1 <- treeModelGetRow rawModel' cIter1
|
||||
item2 <- treeModelGetRow rawModel' cIter2
|
||||
return $ compare item1 item2
|
||||
treeSortableSetSortColumnId sortedModel' 1 SortAscending
|
||||
|
||||
-- set values
|
||||
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
|
||||
(dirtreePix . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 1)
|
||||
(name . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 2)
|
||||
(packModTime . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 3)
|
||||
(packPermissions . file)
|
||||
|
||||
-- update model of view
|
||||
case view' of
|
||||
FMTreeView treeView -> do
|
||||
treeViewSetModel treeView sortedModel'
|
||||
treeViewSetRubberBanding treeView True
|
||||
FMIconView iconView -> do
|
||||
iconViewSetModel iconView (Just sortedModel')
|
||||
iconViewSetPixbufColumn iconView
|
||||
(makeColumnIdPixbuf 0 :: ColumnId item Pixbuf)
|
||||
iconViewSetTextColumn iconView
|
||||
(makeColumnIdString 1 :: ColumnId item String)
|
||||
|
||||
-- add watcher
|
||||
mi <- tryTakeMVar (inotify myview)
|
||||
for_ mi $ \i -> killINotify i
|
||||
newi <- initINotify
|
||||
w <- addWatch
|
||||
newi
|
||||
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
|
||||
cdirp
|
||||
(\_ -> postGUIAsync $ refreshView mygui myview (Just cdirp))
|
||||
putMVar (inotify myview) newi
|
||||
|
||||
return ()
|
||||
where
|
||||
dirtreePix (Dir {}) = folderPix mygui
|
||||
dirtreePix (FileLike {}) = filePix mygui
|
||||
dirtreePix (DirSym _) = folderSymPix mygui
|
||||
dirtreePix (FileLikeSym {}) = fileSymPix mygui
|
||||
dirtreePix (Failed {}) = errorPix mygui
|
||||
dirtreePix (BrokenSymlink _) = errorPix mygui
|
||||
dirtreePix _ = errorPix mygui
|
@ -25,30 +25,14 @@ import Control.Applicative
|
||||
(
|
||||
(<$>)
|
||||
)
|
||||
import Control.Concurrent.MVar
|
||||
(
|
||||
putMVar
|
||||
, tryTakeMVar
|
||||
)
|
||||
import Control.Concurrent.STM
|
||||
(
|
||||
TVar
|
||||
, newTVarIO
|
||||
, readTVarIO
|
||||
readTVarIO
|
||||
)
|
||||
import Data.DirTree
|
||||
import Data.Foldable
|
||||
(
|
||||
for_
|
||||
)
|
||||
import Data.List
|
||||
(
|
||||
isPrefixOf
|
||||
)
|
||||
import Data.Maybe
|
||||
(
|
||||
catMaybes
|
||||
, fromMaybe
|
||||
, fromJust
|
||||
)
|
||||
import Data.Traversable
|
||||
@ -57,17 +41,6 @@ import Data.Traversable
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import GUI.Gtk.Data
|
||||
import IO.Error
|
||||
import IO.Utils
|
||||
import MyPrelude
|
||||
import System.INotify
|
||||
(
|
||||
addWatch
|
||||
, initINotify
|
||||
, killINotify
|
||||
, EventVariety(..)
|
||||
, Event(..)
|
||||
)
|
||||
|
||||
|
||||
|
||||
@ -77,22 +50,34 @@ import System.INotify
|
||||
-----------------
|
||||
|
||||
|
||||
-- |Gets the currently selected row of the treeView, if any.
|
||||
--
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'rawModel' reads
|
||||
-- * 'sortedModel' reads
|
||||
-- * 'filteredModel' reads
|
||||
getSelectedRows :: MyGUI
|
||||
-> MyView
|
||||
-> IO [Row]
|
||||
getSelectedRows mygui myview = do
|
||||
tvs <- treeViewGetSelection (treeView mygui)
|
||||
tps <- treeSelectionGetSelectedRows tvs
|
||||
getSelectedTreePaths :: MyGUI -> MyView -> IO [TreePath]
|
||||
getSelectedTreePaths _ myview = do
|
||||
view' <- readTVarIO $ view myview
|
||||
case view' of
|
||||
FMTreeView treeView -> do
|
||||
tvs <- treeViewGetSelection treeView
|
||||
treeSelectionGetSelectedRows tvs
|
||||
FMIconView iconView ->
|
||||
iconViewGetSelectedItems iconView
|
||||
|
||||
|
||||
-- |Gets the currently selected item of the treeView, if any.
|
||||
getSelectedItems :: MyGUI
|
||||
-> MyView
|
||||
-> IO [Item]
|
||||
getSelectedItems mygui myview = do
|
||||
tps <- getSelectedTreePaths mygui myview
|
||||
getSelectedItems' mygui myview tps
|
||||
|
||||
|
||||
getSelectedItems' :: MyGUI
|
||||
-> MyView
|
||||
-> [TreePath]
|
||||
-> IO [Item]
|
||||
getSelectedItems' mygui myview tps = do
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
sortedModel' <- readTVarIO $ sortedModel myview
|
||||
filteredModel' <- readTVarIO $ filteredModel myview
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
iters <- catMaybes <$> mapM (treeModelGetIter sortedModel') tps
|
||||
forM iters $ \iter -> do
|
||||
cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
|
||||
@ -100,19 +85,21 @@ getSelectedRows mygui myview = do
|
||||
treeModelGetRow rawModel' cIter
|
||||
|
||||
|
||||
-- |Carry out an action on the currently selected row.
|
||||
|
||||
|
||||
-- |Carry out an action on the currently selected item.
|
||||
--
|
||||
-- If there is no row selected, does nothing.
|
||||
withRows :: MyGUI
|
||||
-> MyView
|
||||
-> ( [Row]
|
||||
-> MyGUI
|
||||
-> MyView
|
||||
-> IO ()) -- ^ action to carry out
|
||||
-> IO ()
|
||||
withRows mygui myview io = do
|
||||
rows <- getSelectedRows mygui myview
|
||||
io rows mygui myview
|
||||
-- If there is no item selected, does nothing.
|
||||
withItems :: MyGUI
|
||||
-> MyView
|
||||
-> ( [Item]
|
||||
-> MyGUI
|
||||
-> MyView
|
||||
-> IO ()) -- ^ action to carry out
|
||||
-> IO ()
|
||||
withItems mygui myview io = do
|
||||
items <- getSelectedItems mygui myview
|
||||
io items mygui myview
|
||||
|
||||
|
||||
-- |Create the 'ListStore' of files/directories from the current directory.
|
||||
@ -120,172 +107,29 @@ withRows mygui myview io = do
|
||||
-- into the GTK+ data structures.
|
||||
fileListStore :: AnchoredFile FileInfo -- ^ current dir
|
||||
-> MyView
|
||||
-> IO (ListStore Row)
|
||||
-> IO (ListStore Item)
|
||||
fileListStore dt myview = do
|
||||
cs <- Data.DirTree.getContents dt
|
||||
listStoreNew cs
|
||||
|
||||
|
||||
-- |Currently unsafe. This is used to obtain any row (possibly the '.' row)
|
||||
-- |Currently unsafe. This is used to obtain any item (possibly the '.' item)
|
||||
-- and extract the "current working directory" from it.
|
||||
--
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'rawModel' reads
|
||||
getFirstRow :: MyView
|
||||
getFirstItem :: MyView
|
||||
-> IO (AnchoredFile FileInfo)
|
||||
getFirstRow myview = do
|
||||
getFirstItem myview = do
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
iter <- fromJust <$> treeModelGetIterFirst rawModel'
|
||||
treeModelGetRow rawModel' iter
|
||||
|
||||
|
||||
-- |Currently unsafe. Gets the current directory via `getFirstRow` and `goUp`.
|
||||
-- |Currently unsafe. Gets the current directory via `getFirstItem` and
|
||||
-- `goUp`.
|
||||
getCurrentDir :: MyView
|
||||
-> IO (AnchoredFile FileInfo)
|
||||
getCurrentDir myview = getFirstRow myview >>= goUp
|
||||
getCurrentDir myview = getFirstItem myview >>= goUp
|
||||
|
||||
|
||||
-- |Re-reads the current directory or the given one and updates the TreeView.
|
||||
--
|
||||
-- The operation may fail with:
|
||||
--
|
||||
-- * 'DirDoesNotExist' if the target directory does not exist
|
||||
-- * 'PathNotAbsolute' if the target directory is not absolute
|
||||
--
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'rawModel' writes
|
||||
refreshTreeView :: MyGUI
|
||||
-> MyView
|
||||
-> Maybe FilePath
|
||||
-> IO ()
|
||||
refreshTreeView mygui myview mfp = do
|
||||
mcdir <- getFirstRow myview
|
||||
let fp = fromMaybe (anchor mcdir) mfp
|
||||
|
||||
-- get selected rows
|
||||
tvs <- treeViewGetSelection (treeView mygui)
|
||||
srows <- treeSelectionGetSelectedRows tvs
|
||||
|
||||
-- TODO catch exceptions
|
||||
dirSanityThrow fp
|
||||
|
||||
newFsState <- Data.DirTree.readFile fp
|
||||
newRawModel <- fileListStore newFsState myview
|
||||
writeTVarIO (rawModel myview) newRawModel
|
||||
|
||||
constructTreeView mygui myview
|
||||
|
||||
-- reselect selected rows
|
||||
mapM_ (treeSelectionSelectPath tvs) srows
|
||||
|
||||
|
||||
-- |Refreshes the TreeView based on the given directory.
|
||||
--
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'rawModel' writes
|
||||
refreshTreeView' :: MyGUI
|
||||
-> MyView
|
||||
-> AnchoredFile FileInfo
|
||||
-> IO ()
|
||||
refreshTreeView' mygui myview dt = do
|
||||
newRawModel <- fileListStore dt myview
|
||||
writeTVarIO (rawModel myview) newRawModel
|
||||
|
||||
-- get selected rows
|
||||
tvs <- treeViewGetSelection (treeView mygui)
|
||||
srows <- treeSelectionGetSelectedRows tvs
|
||||
|
||||
constructTreeView mygui myview
|
||||
|
||||
-- reselect selected rows
|
||||
mapM_ (treeSelectionSelectPath tvs) srows
|
||||
|
||||
|
||||
-- TODO: make this function more slim so only the most necessary parts are
|
||||
-- called
|
||||
-- |Constructs the visible TreeView with the current underlying mutable models,
|
||||
-- which are retrieved from 'MyGUI'.
|
||||
--
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'rawModel' reads
|
||||
-- * 'filteredModel' writes
|
||||
-- * 'sortedModel' writes
|
||||
-- * 'settings' reads
|
||||
constructTreeView :: MyGUI
|
||||
-> MyView
|
||||
-> IO ()
|
||||
constructTreeView mygui myview = do
|
||||
let treeView' = treeView mygui
|
||||
cF' = cF mygui
|
||||
cMD' = cMD mygui
|
||||
render' = renderTxt mygui
|
||||
|
||||
cdirp <- anchor <$> getFirstRow myview
|
||||
|
||||
-- update urlBar
|
||||
entrySetText (urlBar mygui) cdirp
|
||||
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
|
||||
-- filtering
|
||||
filteredModel' <- treeModelFilterNew rawModel' []
|
||||
writeTVarIO (filteredModel myview) filteredModel'
|
||||
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
|
||||
hidden <- showHidden <$> readTVarIO (settings mygui)
|
||||
row <- (name . file) <$> treeModelGetRow rawModel' iter
|
||||
if hidden
|
||||
then return True
|
||||
else return $ not . hiddenFile $ row
|
||||
|
||||
-- sorting
|
||||
sortedModel' <- treeModelSortNewWithModel filteredModel'
|
||||
writeTVarIO (sortedModel myview) sortedModel'
|
||||
treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
|
||||
cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
|
||||
cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
|
||||
row1 <- treeModelGetRow rawModel' cIter1
|
||||
row2 <- treeModelGetRow rawModel' cIter2
|
||||
return $ compare row1 row2
|
||||
treeSortableSetSortColumnId sortedModel' 1 SortAscending
|
||||
|
||||
-- set values
|
||||
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
|
||||
(dirtreePix . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 1)
|
||||
(name . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 2)
|
||||
(packModTime . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 3)
|
||||
(packPermissions . file)
|
||||
|
||||
-- update treeview model
|
||||
treeViewSetModel treeView' sortedModel'
|
||||
treeViewSetRubberBanding treeView' True
|
||||
|
||||
-- add watcher
|
||||
mi <- tryTakeMVar (inotify myview)
|
||||
for_ mi $ \i -> killINotify i
|
||||
newi <- initINotify
|
||||
w <- addWatch
|
||||
newi
|
||||
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
|
||||
cdirp
|
||||
(\_ -> postGUIAsync $ refreshTreeView mygui myview (Just cdirp))
|
||||
putMVar (inotify myview) newi
|
||||
|
||||
return ()
|
||||
where
|
||||
dirtreePix (Dir {}) = folderPix mygui
|
||||
dirtreePix (FileLike {}) = filePix mygui
|
||||
dirtreePix (DirSym _) = folderSymPix mygui
|
||||
dirtreePix (FileLikeSym {}) = fileSymPix mygui
|
||||
dirtreePix (Failed {}) = errorPix mygui
|
||||
dirtreePix (BrokenSymlink _) = errorPix mygui
|
||||
dirtreePix _ = errorPix mygui
|
||||
|
||||
|
||||
-- |Push a message to the status bar.
|
||||
|
Loading…
Reference in New Issue
Block a user