From b266b78e14e1f2a3bb0ab89a01c241f1cb0e84da Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 30 Dec 2015 17:53:16 +0100 Subject: [PATCH] GTK: add IconView and refactor the modules --- data/Gtk/builder.xml | 39 ++++- hsfm.cabal | 2 + src/GUI/Gtk.hs | 263 ++--------------------------- src/GUI/Gtk/Callbacks.hs | 282 +++++++++++++++---------------- src/GUI/Gtk/Callbacks.hs-boot | 25 +++ src/GUI/Gtk/Data.hs | 31 ++-- src/GUI/Gtk/MyGUI.hs | 123 ++++++++++++++ src/GUI/Gtk/MyView.hs | 307 ++++++++++++++++++++++++++++++++++ src/GUI/Gtk/Utils.hs | 252 ++++++---------------------- 9 files changed, 706 insertions(+), 618 deletions(-) create mode 100644 src/GUI/Gtk/Callbacks.hs-boot create mode 100644 src/GUI/Gtk/MyGUI.hs create mode 100644 src/GUI/Gtk/MyView.hs 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 + + True + False + gtk-zoom-fit + False @@ -229,8 +234,31 @@ True False - _View - True + View + + + True + False + + + Tree View + True + False + image4 + False + + + + + Icon view + True + False + image5 + False + + + + @@ -280,7 +308,7 @@ - + gtk-refresh True True @@ -368,4 +396,9 @@ + + True + False + gtk-zoom-fit + 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.