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

LIB/GTK: refactor File API and add copyFile

Browse Source
This commit is contained in:
Julian Ospald 2015-12-17 23:08:02 +01:00
parent d5c6eef49e
commit 87ad7d02f0
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
4 changed files with 219 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Data/DirTree/Zipper.hs
View File

@ -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

76
src/GUI/Gtk/Gui.hs
View File

@ -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"

62
src/IO/Error.hs
View File

@ -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)

129
src/IO/File.hs
View File

@ -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)