LIB/GTK: refactor File API and add copyFile
This commit is contained in:
parent
d5c6eef49e
commit
87ad7d02f0
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -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
129
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue