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

GTK: implement selecting multiple rows (and operations on them) 

Not all operations yet support it and will throw an InvalidOperation
error in that case.
This commit is contained in:
Julian Ospald 2015-12-27 18:17:33 +01:00
parent c454fb0b9e
commit aba62f03f2
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
4 changed files with 97 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Data/DirTree.hs
View File

@ -361,6 +361,13 @@ pattern FileLikeSym f <- (fileLikeSym -> (True, f))
pattern ABrokenSymlink f <- (abrokenSymlink -> (True, f)) pattern ABrokenSymlink f <- (abrokenSymlink -> (True, f))
pattern BrokenSymlink f <- (brokenSymlink -> (True, f)) pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
pattern DirList fs <- (\fs -> (foldr (&&) True . fmap (fst . sadir) $ fs, fs)
-> (True, fs))
pattern FileLikeList fs <- (\fs -> (foldr (&&) True
. fmap (fst . safileLike)
$ fs, fs) -> (True, fs))
----------------- -----------------

3
src/GUI/Gtk.hs
View File

@ -235,6 +235,9 @@ startMainWindow startdir = do
-- create the final view -- create the final view
treeView <- treeViewNew treeView <- treeViewNew
-- set selection mode
tvs <- treeViewGetSelection treeView
treeSelectionSetMode tvs SelectionMultiple
-- create final tree model columns -- create final tree model columns
renderTxt <- cellRendererTextNew renderTxt <- cellRendererTextNew

98
src/GUI/Gtk/Callbacks.hs
View File

@ -32,9 +32,14 @@ import Control.Concurrent.STM
, newTVarIO , newTVarIO
, readTVarIO , readTVarIO
) )
import Control.Exception
(
throw
)
import Control.Monad import Control.Monad
( (
void void
, forM_
) )
import Control.Monad.IO.Class import Control.Monad.IO.Class
( (
@ -49,6 +54,7 @@ import Graphics.UI.Gtk
import GUI.Gtk.Data import GUI.Gtk.Data
import GUI.Gtk.Dialogs import GUI.Gtk.Dialogs
import GUI.Gtk.Utils import GUI.Gtk.Utils
import IO.Error
import IO.File import IO.File
import IO.Utils import IO.Utils
import System.Directory import System.Directory
@ -99,17 +105,20 @@ setCallbacks mygui myview = do
liftIO $ upDir mygui myview liftIO $ upDir mygui myview
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
"Delete" <- fmap glibToString eventKeyName "Delete" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview del liftIO $ withRows mygui myview del
_ <- treeView mygui `on` rowActivated $ (\_ _ -> withRow mygui myview open) _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[] <- eventModifier
"Return" <- fmap glibToString eventKeyName
liftIO $ withRows mygui myview open
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview _ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"c" <- fmap glibToString eventKeyName "c" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview copyInit liftIO $ withRows mygui myview copyInit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"x" <- fmap glibToString eventKeyName "x" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview moveInit liftIO $ withRows mygui myview moveInit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"v" <- fmap glibToString eventKeyName "v" <- fmap glibToString eventKeyName
@ -122,23 +131,23 @@ setCallbacks mygui myview = do
-- menubar-file -- menubar-file
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
_ <- menubarFileOpen mygui `on` menuItemActivated $ _ <- menubarFileOpen mygui `on` menuItemActivated $
liftIO $ withRow mygui myview open liftIO $ withRows mygui myview open
_ <- menubarFileExecute mygui `on` menuItemActivated $ _ <- menubarFileExecute mygui `on` menuItemActivated $
liftIO $ withRow mygui myview execute liftIO $ withRows mygui myview execute
_ <- menubarFileNew mygui `on` menuItemActivated $ _ <- menubarFileNew mygui `on` menuItemActivated $
liftIO $ newFile mygui myview liftIO $ newFile mygui myview
-- menubar-edit -- menubar-edit
_ <- menubarEditCut mygui `on` menuItemActivated $ _ <- menubarEditCut mygui `on` menuItemActivated $
liftIO $ withRow mygui myview moveInit liftIO $ withRows mygui myview moveInit
_ <- menubarEditCopy mygui `on` menuItemActivated $ _ <- menubarEditCopy mygui `on` menuItemActivated $
liftIO $ withRow mygui myview copyInit liftIO $ withRows mygui myview copyInit
_ <- menubarEditRename mygui `on` menuItemActivated $ _ <- menubarEditRename mygui `on` menuItemActivated $
liftIO $ withRow mygui myview renameF liftIO $ withRows mygui myview renameF
_ <- menubarEditPaste mygui `on` menuItemActivated $ _ <- menubarEditPaste mygui `on` menuItemActivated $
liftIO $ operationFinal mygui myview liftIO $ operationFinal mygui myview
_ <- menubarEditDelete mygui `on` menuItemActivated $ _ <- menubarEditDelete mygui `on` menuItemActivated $
liftIO $ withRow mygui myview del liftIO $ withRows mygui myview del
-- menubar-help -- menubar-help
_ <- menubarHelpAbout mygui `on` menuItemActivated $ _ <- menubarHelpAbout mygui `on` menuItemActivated $
@ -153,21 +162,21 @@ setCallbacks mygui myview = do
_ -> return () _ -> return ()
return False return False
_ <- rcFileOpen mygui `on` menuItemActivated $ _ <- rcFileOpen mygui `on` menuItemActivated $
liftIO $ withRow mygui myview open liftIO $ withRows mygui myview open
_ <- rcFileExecute mygui `on` menuItemActivated $ _ <- rcFileExecute mygui `on` menuItemActivated $
liftIO $ withRow mygui myview execute liftIO $ withRows mygui myview execute
_ <- rcFileNew mygui `on` menuItemActivated $ _ <- rcFileNew mygui `on` menuItemActivated $
liftIO $ newFile mygui myview liftIO $ newFile mygui myview
_ <- rcFileCopy mygui `on` menuItemActivated $ _ <- rcFileCopy mygui `on` menuItemActivated $
liftIO $ withRow mygui myview copyInit liftIO $ withRows mygui myview copyInit
_ <- rcFileRename mygui `on` menuItemActivated $ _ <- rcFileRename mygui `on` menuItemActivated $
liftIO $ withRow mygui myview renameF liftIO $ withRows mygui myview renameF
_ <- rcFilePaste mygui `on` menuItemActivated $ _ <- rcFilePaste mygui `on` menuItemActivated $
liftIO $ operationFinal mygui myview liftIO $ operationFinal mygui myview
_ <- rcFileDelete mygui `on` menuItemActivated $ _ <- rcFileDelete mygui `on` menuItemActivated $
liftIO $ withRow mygui myview del liftIO $ withRows mygui myview del
_ <- rcFileCut mygui `on` menuItemActivated $ _ <- rcFileCut mygui `on` menuItemActivated $
liftIO $ withRow mygui myview moveInit liftIO $ withRows mygui myview moveInit
return () return ()
@ -184,29 +193,46 @@ urlGoTo mygui myview = withErrorDialog $ do
refreshTreeView mygui myview (Just fp) refreshTreeView mygui myview (Just fp)
-- |Supposed to be used with 'withRow'. Opens a file or directory. -- |Supposed to be used with 'withRows'. Opens a file or directory.
open :: Row -> MyGUI -> MyView -> IO () open :: [Row] -> MyGUI -> MyView -> IO ()
open row mygui myview = withErrorDialog $ open [row] mygui myview = withErrorDialog $
case row of case row of
ADirOrSym r -> do ADirOrSym r -> do
nv <- Data.DirTree.readFile $ fullPath r nv <- Data.DirTree.readFile $ fullPath r
refreshTreeView' mygui myview nv refreshTreeView' mygui myview nv
r -> r ->
void $ openFile r void $ openFile r
-- this throws on the first error that occurs
open (FileLikeList fs) mygui myview = withErrorDialog $
forM_ fs $ \f -> void $ openFile f
open _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Execute a given file. -- |Execute a given file.
execute :: Row -> MyGUI -> MyView -> IO () execute :: [Row] -> MyGUI -> MyView -> IO ()
execute row mygui myview = withErrorDialog $ execute [row] mygui myview = withErrorDialog $
void $ executeFile row [] void $ executeFile row []
execute _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Supposed to be used with 'withRow'. Deletes a file or directory. -- |Supposed to be used with 'withRows'. Deletes a file or directory.
del :: Row -> MyGUI -> MyView -> IO () del :: [Row] -> MyGUI -> MyView -> IO ()
del row mygui myview = withErrorDialog $ do del [row] mygui myview = withErrorDialog $ do
let cmsg = "Really delete \"" ++ fullPath row ++ "\"?" let cmsg = "Really delete \"" ++ fullPath row ++ "\"?"
withConfirmationDialog cmsg withConfirmationDialog cmsg
$ easyDelete row $ easyDelete row
-- this throws on the first error that occurs
del rows@(_:_) mygui myview = withErrorDialog $ do
let cmsg = "Really delete " ++ show (length rows) ++ " files?"
withConfirmationDialog cmsg
$ forM_ rows $ \row -> easyDelete row
del _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Initializes a file move operation. -- |Initializes a file move operation.
@ -214,19 +240,24 @@ del row mygui myview = withErrorDialog $ do
-- Interaction with mutable references: -- Interaction with mutable references:
-- --
-- * 'operationBuffer' writes -- * 'operationBuffer' writes
moveInit :: Row -> MyGUI -> MyView -> IO () moveInit :: [Row] -> MyGUI -> MyView -> IO ()
moveInit row mygui myview = moveInit [row] mygui myview =
writeTVarIO (operationBuffer myview) (FMove . MP1 $ row) writeTVarIO (operationBuffer myview) (FMove . MP1 $ row)
moveInit _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
-- |Supposed to be used with 'withRow'. Initializes a file copy operation.
-- --
-- Interaction with mutable references: -- Interaction with mutable references:
-- --
-- * 'operationBuffer' writes -- * 'operationBuffer' writes
copyInit :: Row -> MyGUI -> MyView -> IO () copyInit :: [Row] -> MyGUI -> MyView -> IO ()
copyInit row mygui myview = copyInit [row] mygui myview =
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ row) writeTVarIO (operationBuffer myview) (FCopy . CP1 $ row)
copyInit _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Finalizes a file operation, such as copy or move. -- |Finalizes a file operation, such as copy or move.
@ -279,10 +310,13 @@ newFile mygui myview = withErrorDialog $ do
createFile cdir fn createFile cdir fn
renameF :: Row -> MyGUI -> MyView -> IO () renameF :: [Row] -> MyGUI -> MyView -> IO ()
renameF row mygui myview = withErrorDialog $ do renameF [row] mygui myview = withErrorDialog $ do
mfn <- textInputDialog "Enter new file name" mfn <- textInputDialog "Enter new file name"
for_ mfn $ \fn -> do for_ mfn $ \fn -> do
let cmsg = "Really rename \"" ++ fullPath row let cmsg = "Really rename \"" ++ fullPath row
++ "\"" ++ " to \"" ++ anchor row </> fn ++ "\"?" ++ "\"" ++ " to \"" ++ anchor row </> fn ++ "\"?"
withConfirmationDialog cmsg $ IO.File.renameFile row fn withConfirmationDialog cmsg $ IO.File.renameFile row fn
renameF _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"

40
src/GUI/Gtk/Utils.hs
View File

@ -47,7 +47,8 @@ import Data.List
) )
import Data.Maybe import Data.Maybe
( (
fromMaybe catMaybes
, fromMaybe
, fromJust , fromJust
) )
import Data.Traversable import Data.Traversable
@ -83,16 +84,17 @@ import System.INotify
-- * 'rawModel' reads -- * 'rawModel' reads
-- * 'sortedModel' reads -- * 'sortedModel' reads
-- * 'filteredModel' reads -- * 'filteredModel' reads
getSelectedRow :: MyGUI getSelectedRows :: MyGUI
-> MyView -> MyView
-> IO (Maybe Row) -> IO [Row]
getSelectedRow mygui myview = do getSelectedRows mygui myview = do
(tp, _) <- treeViewGetCursor $ treeView mygui tvs <- treeViewGetSelection (treeView mygui)
rawModel' <- readTVarIO $ rawModel myview tps <- treeSelectionGetSelectedRows tvs
sortedModel' <- readTVarIO $ sortedModel myview sortedModel' <- readTVarIO $ sortedModel myview
filteredModel' <- readTVarIO $ filteredModel myview filteredModel' <- readTVarIO $ filteredModel myview
miter <- treeModelGetIter sortedModel' tp rawModel' <- readTVarIO $ rawModel myview
forM miter $ \iter -> do iters <- catMaybes <$> mapM (treeModelGetIter sortedModel') tps
forM iters $ \iter -> do
cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
cIter <- treeModelFilterConvertIterToChildIter filteredModel' cIter' cIter <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
treeModelGetRow rawModel' cIter treeModelGetRow rawModel' cIter
@ -101,16 +103,16 @@ getSelectedRow mygui myview = do
-- |Carry out an action on the currently selected row. -- |Carry out an action on the currently selected row.
-- --
-- If there is no row selected, does nothing. -- If there is no row selected, does nothing.
withRow :: MyGUI withRows :: MyGUI
-> MyView -> MyView
-> ( Row -> ( [Row]
-> MyGUI -> MyGUI
-> MyView -> MyView
-> IO ()) -- ^ action to carry out -> IO ()) -- ^ action to carry out
-> IO () -> IO ()
withRow mygui myview io = do withRows mygui myview io = do
mrow <- getSelectedRow mygui myview rows <- getSelectedRows mygui myview
for_ mrow $ \row -> io row mygui myview io rows mygui myview
-- |Create the 'ListStore' of files/directories from the current directory. -- |Create the 'ListStore' of files/directories from the current directory.