diff --git a/src/Data/DirTree/Zipper.hs b/src/Data/DirTree/Zipper.hs index 8b7b669..59fedc1 100644 --- a/src/Data/DirTree/Zipper.hs +++ b/src/Data/DirTree/Zipper.hs @@ -39,6 +39,8 @@ import qualified Data.List as DL -- are the breadcrumbs. type DTZipper a b = (DirTree a b, [DirTree a b]) +type DTInfoZipper = DTZipper DirTreeInfo DirTreeInfo + -- |The base zipper of a tree with empty crumbs element. baseZipper :: DirTree a b -> DTZipper a b diff --git a/src/GUI/Gtk/Gui.hs b/src/GUI/Gtk/Gui.hs index d783921..a6c8723 100644 --- a/src/GUI/Gtk/Gui.hs +++ b/src/GUI/Gtk/Gui.hs @@ -135,14 +135,15 @@ data FMSettings = MkFMSettings { -- because we might want to have multiple views. data MyView = MkMyView { -- |raw model with unsorted data - rawModel :: TVar (ListStore (DTZipper DirTreeInfo DirTreeInfo)) + rawModel :: TVar (ListStore DTInfoZipper) -- |sorted proxy model - , sortedModel :: TVar (TypedTreeModelSort - (DTZipper DirTreeInfo DirTreeInfo)) + , sortedModel :: TVar (TypedTreeModelSort DTInfoZipper) -- |filtered proxy model - , filteredModel :: TVar (TypedTreeModelFilter - (DTZipper DirTreeInfo DirTreeInfo)) - , fsState :: TVar (DTZipper DirTreeInfo DirTreeInfo) + , filteredModel :: TVar (TypedTreeModelFilter DTInfoZipper) + , fsState :: TVar DTInfoZipper + , operationBuffer :: TVar (Either + (DTInfoZipper -> FileOperation DirTreeInfo DirTreeInfo) + (FileOperation DirTreeInfo DirTreeInfo)) } @@ -169,6 +170,14 @@ setCallbacks mygui myview = do _ <- treeView mygui `on` rowActivated $ (\_ _ -> withRow mygui myview open) _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit _ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview + _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do + [Control] <- eventModifier + "c" <- fmap glibToString eventKeyName + liftIO $ withRow mygui myview copyInit + _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do + [Control] <- eventModifier + "v" <- fmap glibToString eventKeyName + liftIO $ copyFinal mygui myview return () @@ -188,7 +197,7 @@ urlGoTo mygui myview = do -- |Gets the currently selected row of the treeView, if any. getSelectedRow :: MyGUI -> MyView - -> IO (Maybe (DTZipper DirTreeInfo DirTreeInfo)) + -> IO (Maybe DTInfoZipper) getSelectedRow mygui myview = do (tp, _) <- treeViewGetCursor $ treeView mygui rawModel' <- readTVarIO $ rawModel myview @@ -206,7 +215,7 @@ getSelectedRow mygui myview = do -- If there is no row selected, does nothing. withRow :: MyGUI -> MyView - -> ( DTZipper DirTreeInfo DirTreeInfo + -> ( DTInfoZipper -> MyGUI -> MyView -> IO ()) -- ^ action to carry out @@ -217,32 +226,65 @@ withRow mygui myview io = do -- |Supposed to be used with `withRow`. Opens a file or directory. -open :: DTZipper DirTreeInfo DirTreeInfo -> MyGUI -> MyView -> IO () +open :: DTInfoZipper -> MyGUI -> MyView -> IO () open row mygui myview = case row of (Dir {}, _) -> refreshTreeView' mygui myview row dz@(File {}, _) -> - withErrorDialog $ openFile (getFullPath dz) + withErrorDialog $ openFile dz _ -> return () -- |Supposed to be used with `withRow`. Deletes a file or directory. -del :: DTZipper DirTreeInfo DirTreeInfo -> MyGUI -> MyView -> IO () +del :: DTInfoZipper -> MyGUI -> MyView -> IO () del row mygui myview = case row of dz@(Dir {}, _) -> do let fp = getFullPath dz cmsg = "Really delete directory \"" ++ fp ++ "\"?" withConfirmationDialog cmsg - $ withErrorDialog (deleteDir fp + $ withErrorDialog (deleteDir dz >> refreshTreeView mygui myview Nothing) dz@(File {}, _) -> do let fp = getFullPath dz cmsg = "Really delete file \"" ++ fp ++ "\"?" withConfirmationDialog cmsg - $ withErrorDialog (deleteFile fp + $ withErrorDialog (deleteFile dz >> refreshTreeView mygui myview Nothing) +-- |Supposed to be used with `withRow`. Initializes a file copy operation. +copyInit :: DTInfoZipper -> MyGUI -> MyView -> IO () +copyInit row mygui myview = case row of + dz@(File {}, _) -> do + print "blah1" + writeTVarIO (operationBuffer myview) (Left $ FCopy dz) + return () + _ -> return () + + +-- |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 () + + -- |Go up one directory and visualize it in the treeView. upDir :: MyGUI -> MyView -> IO () upDir mygui myview = do @@ -257,9 +299,9 @@ upDir mygui myview = do -- into the GTK+ data structures. -- -- This also updates the TVar `fsState` inside the given view. -fileListStore :: DTZipper DirTreeInfo DirTreeInfo -- ^ current dir +fileListStore :: DTInfoZipper -- ^ current dir -> MyView - -> IO (ListStore (DTZipper DirTreeInfo DirTreeInfo)) + -> IO (ListStore DTInfoZipper) fileListStore dtz myview = do writeTVarIO (fsState myview) dtz listStoreNew (goAllDown dtz) @@ -297,7 +339,7 @@ refreshTreeView mygui myview mfp = do -- This also updates the TVar `rawModel`. refreshTreeView' :: MyGUI -> MyView - -> DTZipper DirTreeInfo DirTreeInfo + -> DTInfoZipper -> IO () refreshTreeView' mygui myview dtz = do newRawModel <- fileListStore dtz myview @@ -433,6 +475,8 @@ startMainWindow = do fsState <- readPath' "/" >>= newTVarIO + operationBuffer <- newTVarIO (Right None) + builder <- builderNew builderAddFromFile builder "data/Gtk/builder.xml" diff --git a/src/IO/Error.hs b/src/IO/Error.hs index e53b79a..1df9c98 100644 --- a/src/IO/Error.hs +++ b/src/IO/Error.hs @@ -7,17 +7,75 @@ module IO.Error where import Control.Exception import Control.Monad ( - mzero - , MonadPlus + unless + , void + , when ) import Data.Typeable +import System.Directory + ( + doesDirectoryExist + , doesFileExist + ) +import System.FilePath + ( + equalFilePath + , isAbsolute + , takeFileName + ) data FmIOException = FileDoesNotExist String | PathNotAbsolute String | FileNotExecutable String + | SameFile String String + | NotAFile String + | NotADir String deriving (Show, Typeable) instance Exception FmIOException + +-- Throws an exception if the filepath is not absolute +-- or the file does not exist. +fileSanityThrow :: FilePath -> IO () +fileSanityThrow fp = do + throwNotAbsolute fp + throwFileDoesNotExist fp + + +-- Throws an exception if the filepath is not absolute +-- or the dir does not exist. +dirSanityThrow :: FilePath -> IO () +dirSanityThrow fp = do + throwNotAbsolute fp + throwDirDoesNotExist fp + + +throwNotAbsolute :: FilePath -> IO () +throwNotAbsolute fp = unless (isAbsolute fp) (throw $ PathNotAbsolute fp) + + +throwDirDoesExist :: FilePath -> IO () +throwDirDoesExist fp = do + exists <- doesDirectoryExist fp + when exists (throw $ FileDoesNotExist fp) + + +throwDirDoesNotExist :: FilePath -> IO () +throwDirDoesNotExist fp = do + exists <- doesDirectoryExist fp + unless exists (throw $ FileDoesNotExist fp) + + +throwFileDoesNotExist :: FilePath -> IO () +throwFileDoesNotExist fp = do + exists <- doesFileExist fp + unless exists (throw $ FileDoesNotExist fp) + + +throwSameFile :: FilePath -- ^ should be canonicalized + -> FilePath -- ^ should be canonicalized + -> IO () +throwSameFile fp1 fp2 = when (equalFilePath fp1 fp2) (throw $ SameFile fp1 fp2) diff --git a/src/IO/File.hs b/src/IO/File.hs index 2ffe3ce..59ea48f 100644 --- a/src/IO/File.hs +++ b/src/IO/File.hs @@ -11,11 +11,15 @@ import Control.Monad ( unless , void + , when ) +import Data.DirTree +import Data.DirTree.Zipper import IO.Error import System.Directory ( - doesDirectoryExist + canonicalizePath + , doesDirectoryExist , doesFileExist , executable , getPermissions @@ -24,7 +28,11 @@ import System.Directory ) import System.FilePath ( - isAbsolute + equalFilePath + , isAbsolute + , takeFileName + , takeDirectory + , () ) import System.Process ( @@ -32,12 +40,72 @@ import System.Process , ProcessHandle ) +import qualified System.Directory as SD -data FileOperation = Copy - | Move - | Delete - | Open - | Execute + +-- TODO: modify the DTZipper directly after file operations!? + + +-- |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 a b = FCopy (DTZipper a b) (DTZipper a b) + | FMove FilePath FilePath + | FDelete (DTZipper a b) + | FOpen (DTZipper a b) + | FExecute (DTZipper a b) [String] + | None + + +runFileOp :: FileOperation a b -> IO () +runFileOp (FCopy from to) = copyFileToDir from to +runFileOp (FDelete fp) = easyDelete fp +runFileOp (FOpen fp) = void $ openFile fp +runFileOp (FExecute fp args) = void $ executeFile fp args +runFileOp _ = return () + + +-- |Copies the given file. +-- +-- This will throw an exception if any of the filepaths are not absolute +-- and an exception if the source file does not exist. +-- +-- If the destination file already exists, it will be replaced. +-- TODO: don't permit copying file A to file A +copyFile :: DTZipper a b -- ^ source file + -> FilePath -- ^ destination file + -> IO () +copyFile from@(File name _, _) to = do + let fp = getFullPath from + fileSanityThrow fp + throwNotAbsolute to + throwDirDoesExist to + toC <- canonicalizePath (takeDirectory to) + let to' = toC takeFileName to + throwSameFile fp to' + SD.copyFile fp to' + + +-- |Copies the given file to the given dir with the same filename. +-- +-- This is just a convenience wrapper around `copyFile`. +copyFileToDir :: DTZipper a b -- ^ source file + -> DTZipper a b -- ^ destination + -> IO () +copyFileToDir from@(File name _, _) to@(Dir {}, _) = do + let dp = getFullPath to + dirSanityThrow dp + copyFile from (dp name) +copyFileToDir from (Dir {}, _) = throw $ NotAFile (getFullPath from) +copyFileToDir _ to = throw $ NotADir (getFullPath to) + + +-- |Copies the given file, regardless of whether the destination is +-- a file or a directory. This is a wrapper around `copyFile` and +-- `copyFileToDir`. +easyCopyFile :: DTZipper a b -> Either FilePath (DTZipper a b) -> IO () +easyCopyFile from (Left to) = copyFile from to +easyCopyFile from (Right to) = copyFileToDir from to -- |Deletes the given file. @@ -47,10 +115,12 @@ data FileOperation = Copy -- -- It also throws exceptions from `removeFile`. -- TODO: threaded, shouldn't block the GUI -deleteFile :: FilePath -> IO () -deleteFile fp = do +deleteFile :: DTZipper a b -> IO () +deleteFile dtz@(File {}, _) = do + let fp = getFullPath dtz fileSanityThrow fp removeFile fp +deleteFile dtz = throw $ NotAFile (getFullPath dtz) -- |Deletes the given directory. @@ -60,21 +130,31 @@ deleteFile fp = do -- -- It also throws exceptions from `removeDirectory`. -- TODO: threaded, shouldn't block the GUI -deleteDir :: FilePath -> IO () -deleteDir fp = do +deleteDir :: DTZipper a b -> IO () +deleteDir dtz@(Dir {}, _) = do + let fp = getFullPath dtz dirSanityThrow fp removeDirectory fp +deleteDir dtz = throw $ NotADir (getFullPath dtz) + + +-- |Deletes a file or directory, whatever it may be. +easyDelete :: DTZipper a b -> IO () +easyDelete dtz@(File {}, _) = deleteFile dtz +easyDelete dtz@(Dir {}, _) = deleteDir dtz -- |Opens a file appropriately by invoking xdg-open. -- -- This will throw an exception if the filepath is not absolute -- or the file does not exist. -openFile :: FilePath -- ^ absolute path to file +openFile :: DTZipper a b -> IO ProcessHandle -openFile fp = do +openFile dtz@(File {}, _) = do + let fp = getFullPath dtz fileSanityThrow fp spawnProcess "xdg-open" [fp] +openFile dtz = throw $ NotAFile (getFullPath dtz) -- |Executes a program with the given arguments. @@ -82,29 +162,14 @@ openFile fp = do -- This will throw an exception if the filepath is not absolute -- or the file does not exist. It will also throw an exception -- if the file is not executable. -executeFile :: FilePath -- ^ absolute path to program +executeFile :: DTZipper a b -- ^ program -> [String] -- ^ arguments -> IO ProcessHandle -executeFile fp args = do +executeFile dtz@(File {}, _) args = do + let fp = getFullPath dtz fileSanityThrow fp p <- getPermissions fp unless (executable p) (throw $ FileNotExecutable fp) spawnProcess fp args +executeFile dtz _ = throw $ NotAFile (getFullPath dtz) - --- Throws an exception if the filepath is not absolute --- or the file does not exist. -fileSanityThrow :: FilePath -> IO () -fileSanityThrow fp = do - unless (isAbsolute fp) (throw $ PathNotAbsolute fp) - exists <- doesFileExist fp - unless exists (throw $ FileDoesNotExist fp) - - --- Throws an exception if the filepath is not absolute --- or the dir does not exist. -dirSanityThrow :: FilePath -> IO () -dirSanityThrow fp = do - unless (isAbsolute fp) (throw $ PathNotAbsolute fp) - exists <- doesDirectoryExist fp - unless exists (throw $ FileDoesNotExist fp)