LIB/GTK: enhance FileOperation type so we can have partial functions

This also add a copy mode dialog to the copy operations.

src/GUI/Gtk/Gui.hs

@@ -141,9 +141,7 @@ data MyView = MkMyView {
   -- |filtered proxy model
   , filteredModel :: TVar (TypedTreeModelFilter DTInfoZipper)
   , fsState :: TVar DTInfoZipper
-  , operationBuffer :: TVar (Either
-                         (DTInfoZipper -> FileOperation)
-                         FileOperation)
+  , operationBuffer :: TVar FileOperation
 }
 
 
@@ -255,30 +253,23 @@ del row mygui myview = case row of
 -- |Supposed to be used with `withRow`. Initializes a file copy operation.
 copyInit :: DTInfoZipper -> MyGUI -> MyView -> IO ()
 copyInit row mygui myview = case row of
-  dz -> writeTVarIO (operationBuffer myview) (Left $ FCopy dz)
+  dz -> writeTVarIO (operationBuffer myview) (FCopy . CP1 $ dz)
 
 
 -- |Finalizes a file copy operation.
 copyFinal :: MyGUI -> MyView -> IO ()
 copyFinal mygui myview = do
-  mOp <- readTVarIO (operationBuffer myview)
-  op <- case mOp of
-    Left pOp -> do
-      curDir <- readTVarIO (fsState myview)
-      case pOp curDir of
-        op@(FCopy _ _) -> return op
-        _              -> return None
-    Right op@(FCopy _ _) -> return op
-    _ -> return None
-  doCopy op
-  where
-    doCopy op@(FCopy from to) = do
-      let cmsg = "Really copy file \"" ++ getFullPath from
-                 ++ "\"" ++ " to \"" ++ getFullPath to ++ "\"?"
-      withConfirmationDialog cmsg
-        $ withErrorDialog
-          (runFileOp op >> refreshTreeView mygui myview Nothing)
-    doCopy _ = return ()
+  op <- readTVarIO (operationBuffer myview)
+  case op of
+    FCopy (CP1 sourceDir) -> do
+      curDir   <- readTVarIO (fsState myview)
+      let cmsg = "Really copy file \"" ++ getFullPath sourceDir
+                 ++ "\"" ++ " to \"" ++ getFullPath curDir ++ "\"?"
+      withConfirmationDialog cmsg $ do
+        copyMode <- showCopyModeChooserDialog
+        withErrorDialog ((runFileOp . FCopy . CC sourceDir curDir $ copyMode)
+                         >> refreshTreeView mygui myview Nothing)
+    _ -> return ()
 
 
 -- |Go up one directory and visualize it in the treeView.
@@ -406,6 +397,7 @@ constructTreeView mygui myview = do
     dirtreePix (Failed {}) = errorPix mygui
 
 
+-- |Push a message to the status bar.
 pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
 pushStatusBar mygui str = do
   let sb = statusBar mygui
@@ -426,21 +418,44 @@ showErrorDialog str = do
   widgetDestroy errorDialog
 
 
+-- |Asks the user for confirmation and returns True/False.
 showConfirmationDialog :: String -> IO Bool
 showConfirmationDialog str = do
-  errorDialog <- messageDialogNew Nothing
-                                  [DialogDestroyWithParent]
-                                  MessageQuestion
-                                  ButtonsYesNo
-                                  str
-  rID <- dialogRun errorDialog
-  widgetDestroy errorDialog
+  confirmDialog <- messageDialogNew Nothing
+                                    [DialogDestroyWithParent]
+                                    MessageQuestion
+                                    ButtonsYesNo
+                                    str
+  rID <- dialogRun confirmDialog
+  widgetDestroy confirmDialog
   case rID of
     ResponseYes -> return True
     ResponseNo  -> return False
     _           -> return False
 
 
+-- |Asks the user which directory copy mode he wants via dialog popup
+-- and returns `DirCopyMode`.
+showCopyModeChooserDialog :: IO DirCopyMode
+showCopyModeChooserDialog = do
+  chooserDialog <- messageDialogNew Nothing
+                                    [DialogDestroyWithParent]
+                                    MessageQuestion
+                                    ButtonsNone
+                                    "Choose the copy mode"
+  dialogAddButton chooserDialog "Strict"  (ResponseUser 0)
+  dialogAddButton chooserDialog "Merge"   (ResponseUser 1)
+  dialogAddButton chooserDialog "Replace" (ResponseUser 2)
+  rID <- dialogRun chooserDialog
+  widgetDestroy chooserDialog
+  case rID of
+    ResponseUser 0 -> return Strict
+    ResponseUser 1 -> return Merge
+    ResponseUser 2 -> return Replace
+
+
+-- |Carry out an IO action with a confirmation dialog.
+-- If the user presses "No", then do nothing.
 withConfirmationDialog :: String -> IO () -> IO ()
 withConfirmationDialog str io = do
   run <- showConfirmationDialog str
@@ -471,7 +486,7 @@ startMainWindow startdir = do
 
   fsState <- readPath' startdir >>= newTVarIO
 
-  operationBuffer <- newTVarIO (Right None)
+  operationBuffer <- newTVarIO None
 
   builder <- builderNew
   builderAddFromFile builder "data/Gtk/builder.xml"

src/IO/File.hs

@@ -61,14 +61,23 @@ import qualified System.Directory as SD
 -- |Data type describing an actual file operation that can be
 -- carried out via `doFile`. Useful to build up a list of operations
 -- or delay operations.
-data FileOperation = FCopy DTInfoZipper DTInfoZipper
-                   | FMove FilePath FilePath
-                   | FDelete DTInfoZipper
-                   | FOpen DTInfoZipper
+data FileOperation = FCopy    Copy
+                   | FMove    Move
+                   | FDelete  DTInfoZipper
+                   | FOpen    DTInfoZipper
                    | FExecute DTInfoZipper [String]
                    | None
 
 
+data Copy = CP1 DTInfoZipper
+          | CP2 DTInfoZipper DTInfoZipper
+          | CC  DTInfoZipper DTInfoZipper DirCopyMode
+
+
+data Move = MP1 DTInfoZipper
+          | MC  DTInfoZipper DTInfoZipper
+
+
 -- |Directory copy modes.
 -- Strict means we fail if the target directory already exists.
 -- Merge means we keep the old directories/files, but overwrite old files
@@ -80,13 +89,16 @@ data DirCopyMode = Strict
                  | Replace
 
 
-runFileOp :: FileOperation -> IO ()
-runFileOp (FCopy from@(File {}, _) to) = copyFileToDir from to
-runFileOp (FCopy from@(Dir {}, _) to) = copyDir Merge from to
-runFileOp (FDelete fp)       = easyDelete fp
-runFileOp (FOpen fp)         = void $ openFile fp
-runFileOp (FExecute fp args) = void $ executeFile fp args
-runFileOp _                  = return ()
+runFileOp :: FileOperation -> IO (Maybe FileOperation)
+runFileOp (FCopy (CC from@(File {}, _) to cm)) =
+  copyFileToDir from to >> return Nothing
+runFileOp (FCopy (CC from@(Dir {}, _) to cm)) =
+  copyDir cm from to >> return Nothing
+runFileOp fo@(FCopy _) = return $ Just fo
+runFileOp (FDelete fp)       = easyDelete fp >> return Nothing
+runFileOp (FOpen fp)         = openFile fp >> return Nothing
+runFileOp (FExecute fp args) = executeFile fp args >> return Nothing
+runFileOp _                  = return Nothing