From aba62f03f25f0f1e76a9aae4fa725c344413786f Mon Sep 17 00:00:00 2001
From: Julian Ospald <hasufell@hasufell.de>
Date: Sun, 27 Dec 2015 18:17:33 +0100
Subject: [PATCH] GTK: implement selecting multiple rows (and operations on
 them)

Not all operations yet support it and will throw an InvalidOperation
error in that case.
---
 src/Data/DirTree.hs      |  7 +++
 src/GUI/Gtk.hs           |  3 ++
 src/GUI/Gtk/Callbacks.hs | 98 +++++++++++++++++++++++++++-------------
 src/GUI/Gtk/Utils.hs     | 40 ++++++++--------
 4 files changed, 97 insertions(+), 51 deletions(-)

diff --git a/src/Data/DirTree.hs b/src/Data/DirTree.hs
index 2253574..793bdbe 100644
--- a/src/Data/DirTree.hs
+++ b/src/Data/DirTree.hs
@@ -361,6 +361,13 @@ pattern FileLikeSym  f <- (fileLikeSym  -> (True, f))
 pattern ABrokenSymlink f <- (abrokenSymlink -> (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))
+
+
 
 
     -----------------
diff --git a/src/GUI/Gtk.hs b/src/GUI/Gtk.hs
index 42bfabf..71e6073 100644
--- a/src/GUI/Gtk.hs
+++ b/src/GUI/Gtk.hs
@@ -235,6 +235,9 @@ startMainWindow startdir = do
 
   -- create the final view
   treeView <- treeViewNew
+  -- set selection mode
+  tvs <- treeViewGetSelection treeView
+  treeSelectionSetMode tvs SelectionMultiple
 
   -- create final tree model columns
   renderTxt <- cellRendererTextNew
diff --git a/src/GUI/Gtk/Callbacks.hs b/src/GUI/Gtk/Callbacks.hs
index 2eb6f16..7da7260 100644
--- a/src/GUI/Gtk/Callbacks.hs
+++ b/src/GUI/Gtk/Callbacks.hs
@@ -32,9 +32,14 @@ import Control.Concurrent.STM
   , newTVarIO
   , readTVarIO
   )
+import Control.Exception
+  (
+    throw
+  )
 import Control.Monad
   (
     void
+  , forM_
   )
 import Control.Monad.IO.Class
   (
@@ -49,6 +54,7 @@ import Graphics.UI.Gtk
 import GUI.Gtk.Data
 import GUI.Gtk.Dialogs
 import GUI.Gtk.Utils
+import IO.Error
 import IO.File
 import IO.Utils
 import System.Directory
@@ -99,17 +105,20 @@ setCallbacks mygui myview = do
     liftIO $ upDir mygui myview
   _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
     "Delete"  <- fmap glibToString eventKeyName
-    liftIO $ withRow mygui myview del
-  _ <- treeView mygui `on` rowActivated $ (\_ _ -> withRow mygui myview open)
+    liftIO $ withRows mygui myview del
+  _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
+    []            <- eventModifier
+    "Return"      <- fmap glibToString eventKeyName
+    liftIO $ withRows mygui myview open
   _ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
   _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
     [Control] <- eventModifier
     "c"       <- fmap glibToString eventKeyName
-    liftIO $ withRow mygui myview copyInit
+    liftIO $ withRows mygui myview copyInit
   _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
     [Control] <- eventModifier
     "x"       <- fmap glibToString eventKeyName
-    liftIO $ withRow mygui myview moveInit
+    liftIO $ withRows mygui myview moveInit
   _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
     [Control] <- eventModifier
     "v"       <- fmap glibToString eventKeyName
@@ -122,23 +131,23 @@ setCallbacks mygui myview = do
   -- menubar-file
   _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
   _ <- menubarFileOpen mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview open
+    liftIO $ withRows mygui myview open
   _ <- menubarFileExecute mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview execute
+    liftIO $ withRows mygui myview execute
   _ <- menubarFileNew mygui `on` menuItemActivated $
     liftIO $ newFile mygui myview
 
   -- menubar-edit
   _ <- menubarEditCut mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview moveInit
+    liftIO $ withRows mygui myview moveInit
   _ <- menubarEditCopy mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview copyInit
+    liftIO $ withRows mygui myview copyInit
   _ <- menubarEditRename mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview renameF
+    liftIO $ withRows mygui myview renameF
   _ <- menubarEditPaste mygui `on` menuItemActivated $
     liftIO $ operationFinal mygui myview
   _ <- menubarEditDelete mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview del
+    liftIO $ withRows mygui myview del
 
   -- menubar-help
   _ <- menubarHelpAbout mygui `on` menuItemActivated $
@@ -153,21 +162,21 @@ setCallbacks mygui myview = do
       _           -> return ()
     return False
   _ <- rcFileOpen mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview open
+    liftIO $ withRows mygui myview open
   _ <- rcFileExecute mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview execute
+    liftIO $ withRows mygui myview execute
   _ <- rcFileNew mygui `on` menuItemActivated $
     liftIO $ newFile mygui myview
   _ <- rcFileCopy mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview copyInit
+    liftIO $ withRows mygui myview copyInit
   _ <- rcFileRename mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview renameF
+    liftIO $ withRows mygui myview renameF
   _ <- rcFilePaste mygui `on` menuItemActivated $
     liftIO $ operationFinal mygui myview
   _ <- rcFileDelete mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview del
+    liftIO $ withRows mygui myview del
   _ <- rcFileCut mygui `on` menuItemActivated $
-    liftIO $ withRow mygui myview moveInit
+    liftIO $ withRows mygui myview moveInit
 
 
   return ()
@@ -184,29 +193,46 @@ urlGoTo mygui myview = withErrorDialog $ do
   refreshTreeView mygui myview (Just fp)
 
 
--- |Supposed to be used with 'withRow'. Opens a file or directory.
-open :: Row -> MyGUI -> MyView -> IO ()
-open row mygui myview = withErrorDialog $
+-- |Supposed to be used with 'withRows'. Opens a file or directory.
+open :: [Row] -> MyGUI -> MyView -> IO ()
+open [row] mygui myview = withErrorDialog $
   case row of
     ADirOrSym r -> do
       nv <- Data.DirTree.readFile $ fullPath r
       refreshTreeView' mygui myview nv
     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 :: Row -> MyGUI -> MyView -> IO ()
-execute row mygui myview = withErrorDialog $
+execute :: [Row] -> MyGUI -> MyView -> IO ()
+execute [row] mygui myview = withErrorDialog $
   void $ executeFile row []
+execute _ _ _ = withErrorDialog
+                  . throw $ InvalidOperation
+                            "Operation not supported on multiple files"
 
 
--- |Supposed to be used with 'withRow'. Deletes a file or directory.
-del :: Row -> MyGUI -> MyView -> IO ()
-del row mygui myview = withErrorDialog $ do
+-- |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 ++ "\"?"
   withConfirmationDialog cmsg
     $ 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.
@@ -214,19 +240,24 @@ del row mygui myview = withErrorDialog $ do
 -- Interaction with mutable references:
 --
 -- * 'operationBuffer' writes
-moveInit :: Row -> MyGUI -> MyView -> IO ()
-moveInit row mygui myview =
+moveInit :: [Row] -> MyGUI -> MyView -> IO ()
+moveInit [row] mygui myview =
   writeTVarIO (operationBuffer myview) (FMove . MP1 $ row)
+moveInit _ _ _ = withErrorDialog
+                   . throw $ InvalidOperation
+                             "Operation not supported on multiple files"
 
-
--- |Supposed to be used with 'withRow'. Initializes a file copy operation.
+-- |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 =
+copyInit :: [Row] -> MyGUI -> MyView -> IO ()
+copyInit [row] mygui myview =
   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.
@@ -279,10 +310,13 @@ newFile mygui myview = withErrorDialog $ do
     createFile cdir fn
 
 
-renameF :: Row -> MyGUI -> MyView -> IO ()
-renameF row mygui myview = withErrorDialog $ do
+renameF :: [Row] -> MyGUI -> MyView -> IO ()
+renameF [row] 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
+renameF _ _ _ = withErrorDialog
+                  . throw $ InvalidOperation
+                            "Operation not supported on multiple files"
diff --git a/src/GUI/Gtk/Utils.hs b/src/GUI/Gtk/Utils.hs
index 2178ef5..70107ea 100644
--- a/src/GUI/Gtk/Utils.hs
+++ b/src/GUI/Gtk/Utils.hs
@@ -47,7 +47,8 @@ import Data.List
   )
 import Data.Maybe
   (
-    fromMaybe
+    catMaybes
+  , fromMaybe
   , fromJust
   )
 import Data.Traversable
@@ -83,16 +84,17 @@ import System.INotify
 -- * 'rawModel' reads
 -- * 'sortedModel' reads
 -- * 'filteredModel' reads
-getSelectedRow :: MyGUI
-               -> MyView
-               -> IO (Maybe Row)
-getSelectedRow mygui myview = do
-  (tp, _)        <- treeViewGetCursor $ treeView mygui
-  rawModel'      <- readTVarIO $ rawModel myview
+getSelectedRows :: MyGUI
+                -> MyView
+                -> IO [Row]
+getSelectedRows mygui myview = do
+  tvs   <- treeViewGetSelection (treeView mygui)
+  tps   <- treeSelectionGetSelectedRows tvs
   sortedModel'   <- readTVarIO $ sortedModel myview
   filteredModel' <- readTVarIO $ filteredModel myview
-  miter          <- treeModelGetIter sortedModel' tp
-  forM miter $ \iter -> do
+  rawModel'      <- readTVarIO $ rawModel myview
+  iters <- catMaybes <$> mapM (treeModelGetIter sortedModel') tps
+  forM iters $ \iter -> do
     cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
     cIter  <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
     treeModelGetRow rawModel' cIter
@@ -101,16 +103,16 @@ getSelectedRow mygui myview = do
 -- |Carry out an action on the currently selected row.
 --
 -- If there is no row selected, does nothing.
-withRow :: MyGUI
-        -> MyView
-        -> (   Row
-            -> MyGUI
-            -> MyView
-            -> IO ()) -- ^ action to carry out
-        -> IO ()
-withRow mygui myview io = do
-  mrow <- getSelectedRow mygui myview
-  for_ mrow $ \row -> io row mygui myview
+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
 
 
 -- |Create the 'ListStore' of files/directories from the current directory.