diff --git a/data/Gtk/builder.xml b/data/Gtk/builder.xml
index e82a7bb..a81a15d 100644
--- a/data/Gtk/builder.xml
+++ b/data/Gtk/builder.xml
@@ -99,6 +99,11 @@
False
gtk-cancel
+
+
diff --git a/hsfm.cabal b/hsfm.cabal
index e202bb6..668b95f 100644
--- a/hsfm.cabal
+++ b/hsfm.cabal
@@ -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
diff --git a/src/GUI/Gtk.hs b/src/GUI/Gtk.hs
index a7f3643..434fbc6 100644
--- a/src/GUI/Gtk.hs
+++ b/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
diff --git a/src/GUI/Gtk/Callbacks.hs b/src/GUI/Gtk/Callbacks.hs
index 33272d1..85b266c 100644
--- a/src/GUI/Gtk/Callbacks.hs
+++ b/src/GUI/Gtk/Callbacks.hs
@@ -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"
diff --git a/src/GUI/Gtk/Callbacks.hs-boot b/src/GUI/Gtk/Callbacks.hs-boot
new file mode 100644
index 0000000..5733f78
--- /dev/null
+++ b/src/GUI/Gtk/Callbacks.hs-boot
@@ -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 ()
diff --git a/src/GUI/Gtk/Data.hs b/src/GUI/Gtk/Data.hs
index 50d40c8..5c149de 100644
--- a/src/GUI/Gtk/Data.hs
+++ b/src/GUI/Gtk/Data.hs
@@ -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
diff --git a/src/GUI/Gtk/MyGUI.hs b/src/GUI/Gtk/MyGUI.hs
new file mode 100644
index 0000000..a4cb67a
--- /dev/null
+++ b/src/GUI/Gtk/MyGUI.hs
@@ -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
diff --git a/src/GUI/Gtk/MyView.hs b/src/GUI/Gtk/MyView.hs
new file mode 100644
index 0000000..642864d
--- /dev/null
+++ b/src/GUI/Gtk/MyView.hs
@@ -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
diff --git a/src/GUI/Gtk/Utils.hs b/src/GUI/Gtk/Utils.hs
index 5eab601..cbe5adf 100644
--- a/src/GUI/Gtk/Utils.hs
+++ b/src/GUI/Gtk/Utils.hs
@@ -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.